{ +-------------------------------------------------------------+ } { | | } { | GM-Software | } { | =========== | } { | | } { | Project: All Projects | } { | | } { | Description: Implementation of the HTTP protocol. | } { | | } { | | } { | Copyright (C) - 2012 - Gerrit Moeller. | } { | | } { | Source code dstributed under MIT license. | } { | | } { | See: https://www.gm-software.de | } { | | } { +-------------------------------------------------------------+ } {$INCLUDE GMCompilerSettings.inc} {.$DEFINE TLS_SUPPORT} // <- Define this to have SSL/TLS support and NTLM authentication. {.$DEFINE HTTP_ZIP_SUPPORT} // <- Define this to have deflate/gzip support for HTTP transfer-encoding. { Proxy: ====== 305 Use Proxy => should be for only a single request! Handle 407 proxy authentication required (Proxy-Authenticate, Proxy-Authorization) In case of 204 (No Conent), HEAD and successful CONNECT requests => limit to content length 0! ToDo: ===== - Chunked Stream trailers: Dont add headers that are not allowed as trailers (content-Length, Transfer-Encoding, Trailers) } {$DEFINE DELAY_LOAD_WIN_DLLs} unit GMHttp; interface uses {$IFDEF JEDIAPI}jwaWinType,{$ELSE}Windows,{$ENDIF} GMActiveX, GMStrDef, GMCollections, GMIntf, GMCommon, GMINetBase, GMSockets {$IFDEF HTTP_ZIP_SUPPORT}, GMZStrm{$ENDIF} {$IFDEF TLS_SUPPORT},GMNtlm{$ENDIF} ; const scStrHttp = 'HTTP'; scStrHttps = 'HTTPS'; scDfltHttpPort = '80'; scDfltHttpsPort = '443'; scHttpDirSeparator = '/'; scGMHttpAgent = 'GM-Http'; // 'GM-Http/1.0' FACILITY_GM_HTTP = 2012; cDfltHttpErrorCode = 0; HTTP_STATUS_CONTINUE = 100; // OK to continue with request HTTP_STATUS_SWITCH_PROTOCOLS = 101; // server has switched protocols in upgrade header HTTP_STATUS_PROCESSING = 102; HTTP_STATUS_OK = 200; // request completed HTTP_STATUS_CREATED = 201; // object created, reason = new URI HTTP_STATUS_ACCEPTED = 202; // async completion (TBS) HTTP_STATUS_PARTIAL = 203; // partial completion HTTP_STATUS_NO_CONTENT = 204; // no info to return HTTP_STATUS_RESET_CONTENT = 205; // request completed, but clear form HTTP_STATUS_PARTIAL_CONTENT = 206; // partial GET furfilled HTTP_MULTI_STATUS = 207; HTTP_STATUS_AMBIGUOUS = 300; // server couldn't decide what to return HTTP_STATUS_MOVED = 301; // object permanently moved HTTP_STATUS_REDIRECT = 302; // object temporarily moved HTTP_STATUS_REDIRECT_METHOD = 303; // redirection w/ new access method HTTP_STATUS_NOT_MODIFIED = 304; // if-modified-since was not modified HTTP_STATUS_USE_PROXY = 305; // redirection to proxy, location header specifies proxy to use HTTP_STATUS_REDIRECT_KEEP_VERB = 307; // HTTP/1.1: keep same verb HTTP_STATUS_BAD_REQUEST = 400; // invalid syntax HTTP_STATUS_DENIED = 401; // access denied HTTP_STATUS_PAYMENT_REQ = 402; // payment required HTTP_STATUS_FORBIDDEN = 403; // request forbidden HTTP_STATUS_NOT_FOUND = 404; // object not found HTTP_STATUS_BAD_METHOD = 405; // method is not allowed HTTP_STATUS_NONE_ACCEPTABLE = 406; // no response acceptable to client found HTTP_STATUS_PROXY_AUTH_REQ = 407; // proxy authentication required HTTP_STATUS_REQUEST_TIMEOUT = 408; // server timed out waiting for request HTTP_STATUS_CONFLICT = 409; // user should resubmit with more info HTTP_STATUS_GONE = 410; // the resource is no longer available HTTP_STATUS_LENGTH_REQUIRED = 411; // the server refused to accept request w/o a length HTTP_STATUS_PRECOND_FAILED = 412; // precondition given in request failed HTTP_STATUS_REQUEST_TOO_LARGE = 413; // request entity was too large HTTP_STATUS_URI_TOO_LONG = 414; // request URI too long HTTP_STATUS_UNSUPPORTED_MEDIA = 415; // unsupported media type HTTP_STATUS_UNPROCESSABLE_ENTITY = 422; HTTP_STATUS_LOCKED = 423; HTTP_STATUS_FAILED_DEPENDENCY = 424; HTTP_STATUS_RETRY_WITH = 449; // retry after doing the appropriate action. HTTP_STATUS_SERVER_ERROR = 500; // internal server error HTTP_STATUS_NOT_SUPPORTED = 501; // required not supported HTTP_STATUS_BAD_GATEWAY = 502; // error response received from gateway HTTP_STATUS_SERVICE_UNAVAIL = 503; // temporarily overloaded HTTP_STATUS_GATEWAY_TIMEOUT = 504; // timed out waiting for gateway HTTP_STATUS_VERSION_NOT_SUP = 505; // HTTP version not supported HTTP_STATUS_INSUFFICIENT_STORAGE = 507; cHttpStatusCodes: array [0..44] of LongInt = ( HTTP_STATUS_CONTINUE, HTTP_STATUS_SWITCH_PROTOCOLS, HTTP_STATUS_PROCESSING, HTTP_STATUS_OK, HTTP_STATUS_CREATED, HTTP_STATUS_ACCEPTED, HTTP_STATUS_PARTIAL, HTTP_STATUS_NO_CONTENT, HTTP_STATUS_RESET_CONTENT, HTTP_STATUS_PARTIAL_CONTENT, HTTP_MULTI_STATUS, HTTP_STATUS_AMBIGUOUS, HTTP_STATUS_MOVED, HTTP_STATUS_REDIRECT, HTTP_STATUS_REDIRECT_METHOD, HTTP_STATUS_NOT_MODIFIED, HTTP_STATUS_USE_PROXY, HTTP_STATUS_REDIRECT_KEEP_VERB, HTTP_STATUS_BAD_REQUEST, HTTP_STATUS_DENIED, HTTP_STATUS_PAYMENT_REQ, HTTP_STATUS_FORBIDDEN, HTTP_STATUS_NOT_FOUND, HTTP_STATUS_BAD_METHOD, HTTP_STATUS_NONE_ACCEPTABLE, HTTP_STATUS_PROXY_AUTH_REQ, HTTP_STATUS_REQUEST_TIMEOUT, HTTP_STATUS_CONFLICT, HTTP_STATUS_GONE, HTTP_STATUS_LENGTH_REQUIRED, HTTP_STATUS_PRECOND_FAILED, HTTP_STATUS_REQUEST_TOO_LARGE, HTTP_STATUS_URI_TOO_LONG, HTTP_STATUS_UNSUPPORTED_MEDIA, HTTP_STATUS_UNPROCESSABLE_ENTITY, HTTP_STATUS_LOCKED, HTTP_STATUS_FAILED_DEPENDENCY, HTTP_STATUS_RETRY_WITH, HTTP_STATUS_SERVER_ERROR, HTTP_STATUS_NOT_SUPPORTED, HTTP_STATUS_BAD_GATEWAY, HTTP_STATUS_SERVICE_UNAVAIL, HTTP_STATUS_GATEWAY_TIMEOUT, HTTP_STATUS_VERSION_NOT_SUP, HTTP_STATUS_INSUFFICIENT_STORAGE ); cHttpContentLength = 'Content-Length'; cHttpContentType = 'Content-Type'; cHttpContentEncoding = 'Content-Encoding'; cHttpWwwAuthenticate = 'WWW-Authenticate'; cHttpProxyAuthenticate = 'Proxy-Authenticate'; cHttpAuthorization = 'Authorization'; cHttpProxyAuthorization = 'Proxy-Authorization'; cHttpConnection = 'Connection'; cHttpKeepAlive = 'keep-alive'; cHttpClose = 'close'; cStrHttpLocation = 'Location'; cHttpAuthBasic = 'Basic'; cHttpAuthNTLM = 'NTLM'; cHttpTransferEncoding = 'Transfer-Encoding'; cHttpChunked = 'chunked'; cHttpTrailers = 'trailers'; cHttpTE = 'TE'; cHttpDeflate = 'deflate'; cHttpGZip = 'gzip'; cHttpUserAgent = 'User-Agent'; cHttpContentText = 'text'; cMimeMultiPart = 'multipart'; cMimeFormData = 'form-data'; cHttpMethodHEAD = 'HEAD'; cHttpMethodGET = 'GET'; cHttpMethodPUT = 'PUT'; cHttpMethodPOST = 'POST'; cHttpMethodOPTIONS = 'OPTIONS'; cHttpMethodCONNECT = 'CONNECT'; cAuthenticateHeaderName: array [Boolean] of TGMString = (cHttpWwwAuthenticate, cHttpProxyAuthenticate); type PGMHttpLoginData = ^RGMHttpLoginData; RGMHttpLoginData = record UserName: PGMChar; Password: PGMChar; end; IGMGetHttpLoginData = interface(IUnknown) ['{31F3BFD4-7506-4CEB-9649-EAC7CCB63C3E}'] function GetHttpLoginData(LoginData: PGMHttpLoginData): HResult; stdcall; end; TGMHttpRequestBase = class(TGMINetProtocolBase) protected FUsingTlsLayer: Boolean; public //function IschunkedTransfer(const AHeaders: IGMIntfCollection): Boolean; function ProtocolDisplayName: TGMString; override; end; TGMHttpClientRequest = class; IGMHttpClientRequest = interface(IUnknown) ['{DE9A0788-0F95-4320-A46A-DE630760EB96}'] function Obj: TGMHttpClientRequest; end; RGMRequestResult = record Request: IGMHttpClientRequest; ResponseContent: ISequentialStream; HttpStatusCode: LongInt; end; RGMResponseHttpStaus = record HttpVersion: TGMString; StatusCode: Integer; ReasonText: TGMSTring; end; TGMHttpClientRequest = class(TGMHttpRequestBase, IGMHttpClientRequest) protected FAgentName: TGMString; FKeepConnection: Boolean; FKeepConnectionTimeout: LongInt; function BuildErrorMsgPostfixFromResponseContent(const AResponseContent: ISequentialStream): TGMString; override; function BuildDecodeStreamChain(const ATransportLayer: ISequentialStream): ISequentialStream; procedure AddStandardHeaders; //procedure CheckResponseStatus(const AResponseStatus: RGMResponseHttpStaus; const AResponseContent: ISequentialStream); function InternalExecute(const ATransportLayer: ISequentialStream; const AUseProxy: Boolean; const AMethod: TGMString; const AUri: RGMUriComponents; const ARequestContent: ISequentialStream; const AAdditionalHeaders: TGMNameAndStrValArray; const AOnUploadProgressProc: TGMOnProgressProc; const AUploadBuffersize: LongInt; const AUsingTlsLayer: Boolean): RGMRequestResult; public constructor Create(const ARefLifeTime: Boolean = True); overload; override; constructor Create(const AAgentName: TGMString = scGMHttpAgent; const ARefLifeTime: Boolean = True); reintroduce; overload; function Obj: TGMHttpClientRequest; function ReceiveHeaders(const ATransportLayer: ISequentialStream; const AHeaders: IGMIntfCollection): TGMString; override; end; IGMHttpClientAuthenticationHandler = interface(IUnknown) ['{EACDD940-D911-45AC-B3A3-FCCE0287C13E}'] procedure AddAuthorizationHeader(const AHeaders: IGMIntfCollection); function AuthSchemeName: TGMString; procedure OnTransportLayerDisconnected; function ProcessAuthDenied(const AResponseHeaders: IGMIntfCollection; const ARetryCount: Integer; const AAskLoginData: IUnknown): Boolean; function GetClassType: TClass; end; TGMHttpClientAuthenticationHandlerBase = class(TGMRefCountedObj, IGMHttpClientAuthenticationHandler) protected FUseProxy: Boolean; FUserName, FPassword, FLastUserName, FLastPassword: TGMString; function AuthorizationHeaderName: TGMString; public constructor Create(const AUseProxy: Boolean; const AUserName, APassword: TGMString; const ARefLifeTime: Boolean = True); reintroduce; overload; procedure AddAuthorizationHeader(const AHeaders: IGMIntfCollection); virtual; function AuthSchemeName: TGMString; virtual; abstract; function ProcessAuthDenied(const AResponseHeaders: IGMIntfCollection; const ARetryCount: Integer; const AAskLoginData: IUnknown): Boolean; virtual; procedure OnTransportLayerDisconnected; virtual; end; TGMHttpClientAuthenticationHandlerClass = class of TGMHttpClientAuthenticationHandlerBase; TGMHttpClientBasicAuthenticationHandler = class(TGMHttpClientAuthenticationHandlerBase) public procedure AddAuthorizationHeader(const AHeaders: IGMIntfCollection); override; function AuthSchemeName: TGMString; override; function ProcessAuthDenied(const AResponseHeaders: IGMIntfCollection; const ARequestRetryCount: Integer; const AAskLoginData: IUnknown): Boolean; override; end; {$IFDEF TLS_SUPPORT} TGMHttpClientNTLMAuthenticationHandler = class(TGMHttpClientAuthenticationHandlerBase) protected FNTLMAuthSate: Integer; FServerResponse: TNTLMServerResponse; public procedure AddAuthorizationHeader(const AHeaders: IGMIntfCollection); override; function AuthSchemeName: TGMString; override; function ProcessAuthDenied(const AResponseHeaders: IGMIntfCollection; const ARequestRetryCount: Integer; const AAskLoginData: IUnknown): Boolean; override; procedure OnTransportLayerDisconnected; override; end; {$ENDIF} IGMHttpClientSession = interface(IUnknown) ['{14AC83F8-7042-4BB0-91D3-706698234881}'] function IsTransportLayerConnected: Boolean; //function ConnectTransportLayer(AProtocol, AHost, APort: TGMString): IGMSocketIO; function ExecuteRequest(AHttpRequest: IGMHttpClientRequest; AUri, AHttpMethod: TGMString; const ARequestContent: ISequentialStream = nil; const AAdditionalHeaders: TGMNameAndStrValArray = []; const AOnUploadProgressProc: TGMOnProgressProc = nil; const AUploadBuffersize: LongInt = -cDfltUiResponseMS): RGMRequestResult; end; IGMHttpProxyConfig = interface(IGMUsernameAndPassword) ['{BE39DECC-39D1-4815-9017-F2163FA30DAA}'] procedure LoadSystemProxySettingsOfCurrentUser; function GetProxyHostUri: TGMString; procedure SetProxyHostUri(const AUri: TGMString); function GetProxyBypass: TGMString; procedure SetProxyBypass(const ABypass: TGMString); function UseProxy(const AUri: TGMString): Boolean; property ProxyHostUri: TGMString read GetProxyHostUri write SetProxyHostUri; property ProxyBypass: TGMString read GetProxyBypass write SetProxyBypass; end; TGMHttpProxyConfig = class(TGMRefCountedObj, IGMHttpProxyConfig) protected FProxyHostUri: TGMString; FProxyBypass: TGMString; FUsername: TGMString; FPassword: TGMString; public constructor Create(const AProxyHostUri: TGMString; const AProxyBypass: TGMString = ''; const AUsername: TGMString = ''; const APassword: TGMString = ''; const ARefLifeTime: Boolean = True); reintroduce; overload; procedure LoadSystemProxySettingsOfCurrentUser; function GetProxyHostUri: TGMString; procedure SetProxyHostUri(const AUri: TGMString); function GetProxyBypass: TGMString; procedure SetProxyBypass(const ABypass: TGMString); function GetUsername: TGMString; procedure SetUsername(const AUsername: TGMString); function GetPassword: TGMString; procedure SetPassword(const APassword: TGMString); function UseProxy(const AUri: TGMString): Boolean; property ProxyHostUri: TGMString read GetProxyHostUri write SetProxyHostUri; property ProxyBypass: TGMString read GetProxyBypass write SetProxyBypass; property Username: TGMString read GetUsername write SetUsername; property Password: TGMString read GetPassword write SetPassword; end; RConnectTransportLayerResult = record TransportLayerConnection: IGMSocketIO; UseProxy: Boolean; end; TGMHttpClientSession = class(TGMRefCountedObj, IGMHttpClientSession) protected //FProxyServer: RGMUriComponents; FProxyConfig: IGMHttpProxyConfig; FTargetHost: RGMUriComponents; FProxyTunnelHost: RGMUriComponents; //FTargetHost: RGMUriComponents; FUsingTlsLayer: Boolean; //FProtocol, FHost, FPort, FUserName, FPassword: TGMString; FTransportLayerConnection: IGMSocketIO; FCreatingProxyTlsTunnel: Boolean; FAskCanceled, FAskLoginData, FCertificateStatusNotifySink: IUnknown; FAuthenticationHandler: IGMHttpClientAuthenticationHandler; FProxyAuthenticationHandler: IGMHttpClientAuthenticationHandler; FCertificateData: AnsiString; function UseProxy(const AUri: TGMSTring): Boolean; procedure DisconnectTransportLayer; procedure CreateAuthentificationHandler(const AHeaders: IGMIntfCollection; var ACurrentHandler: IGMHttpClientAuthenticationHandler; const AUseProxy: Boolean; const AUserName, APassword: TGMString); function InternalConnectTransportLayer(const ATargetUri, AProxyUri: RGMUriComponents): IGMSocketIO; public constructor Create(const AAskCanceled, AAskLoginData, ACertificateStatusNotifySink: IUnknown; const AUserName: TGMString = ''; const APassword: TGMString = ''; const AProxyConfig: IGMHttpProxyConfig = nil; const ACertificateData: Ansistring = ''; const ARefLifeTime: Boolean = True); reintroduce; destructor Destroy; override; function IsTransportLayerConnected: Boolean; function ConnectTransportLayer(const AUri: TGMString): RConnectTransportLayerResult; function ExecuteRequest(AHttpRequest: IGMHttpClientRequest; AUri, AHttpMethod: TGMString; const ARequestContent: ISequentialStream = nil; const AAdditionalHeaders: TGMNameAndStrValArray = []; const AOnUploadProgressProc: TGMOnProgressProc = nil; const AUploadBuffersize: LongInt = -cDfltUiResponseMS): RGMRequestResult; end; TGMHttpServerRequest = class; IGMHttpServerRequest = interface(IUnknown) ['{083ABEC1-305C-4CEC-B4CD-3321A0E43FBC}'] function Obj: TGMHttpServerRequest; end; IGMProcessServerRequest = interface(IUnknown) ['{77245904-4C76-49E2-A7E7-A4A620E9347B}'] function ProcessRequest(const ARequest: IGMHttpServerRequest; const AMethod, AURL: TGMString): LongInt; stdcall; // const AContentStream: ISequentialStream procedure SendResponseContents(const ATransportLayer: ISequentialStream); stdcall; end; TGMHttpServerRequest = class(TGMHttpRequestBase, IGMHttpServerRequest) protected procedure AddMinimalResponseHeaders(const AHeaders: IGMIntfCollection); public procedure ProcessRequest(const ATransportLayer: ISequentialStream; const ARequestProcessor: IUnknown); function Obj: TGMHttpServerRequest; end; IGMHttpContentInfo = interface(IUnknown) ['{75BD24C1-B265-488C-9CD6-38FBD23EB587}'] function ContentType: TGMString; function ContentEncoding: TGMString; procedure SetContentType(const AContentType: TGMString); procedure SetContentEncoding(const AContentEncoding: TGMString); end; TGMHttpContentInfoImpl = class(TGMRefCountedObj, IGMHttpContentInfo) protected FContentType, FContentEncoding: TGMString; public function ContentType: TGMString; function ContentEncoding: TGMString; procedure SetContentType(const AContentType: TGMString); procedure SetContentEncoding(const AContentEncoding: TGMString); end; TGMHttpSocketStream = class(TGMSocketStream, IGMHttpContentInfo) protected FHttpContentInfo: IGMHttpContentInfo; public constructor Create(const ARefLifeTime: Boolean = True); override; property HttpContentInfo: IGMHttpContentInfo read FHttpContentInfo implements IGMHttpContentInfo; end; {$IFDEF HTTP_ZIP_SUPPORT} TGMHttpZipDecompressorIStream = class(TGMZipDecompressorIStream, IGMHttpContentInfo) protected FHttpContentInfo: IGMHttpContentInfo; public constructor Create(const ARefLifeTime: Boolean = True); overload; override; property HttpContentInfo: IGMHttpContentInfo read FHttpContentInfo implements IGMHttpContentInfo; end; {$ENDIF} TGMHttpChunkedStream = class(TGMSequentialIStream, IGMHttpContentInfo) protected FProtocolObj: IGMINetProtocolBase; FChainedStream: ISequentialStream; FChunkData: AnsiString; FChunkReadPos: LongInt; FEOS: Boolean; FHttpContentInfo: IGMHttpContentInfo; procedure ReadChunk; // : Boolean; procedure InternalRead(pv: Pointer; cb: LongWord; var pcbRead: LongWord); override; procedure InternalWrite(pv: Pointer; cb: LongWord; var pcbWritten: LongWord); override; public constructor Create(const ARefLifeTime: Boolean = True); overload; override; constructor CreateRead(const AProtocolObj: IGMINetProtocolBase; const AChainedStream: ISequentialStream; const AMode: DWORD = STGM_READ or STGM_WRITE; const AName: UnicodeString = ''; const ARefLifeTime: Boolean = True); reintroduce; overload; property HttpContentInfo: IGMHttpContentInfo read FHttpContentInfo implements IGMHttpContentInfo; end; EGMHttpException = class(EGMINetException, IGMGetHRCode) protected FErrorCode: LongInt; public constructor HttpError(const AHttpStatusCode: LongInt; const AReason: TGMString; const APostFix: TGMString = ''; const ACaller: TObject = nil; const ACallingName: TGMString = ''); function GetHRCode: HResult; stdcall; end; function GMMakeHttpHResult(const AHttpErrorCode: LongInt): HResult; function GMExtractHttpCodeFromHResult(const AHResult: HResult; const ADefaultCode: LongInt = 599): LongInt; //function GMExtractHttpCodeFromHResult(const AHrCode: HResult): LongWord; function GMExecuteHttpRequest(const AUri: TGMString; const AAskCanceled: IUnknown = nil; const AAskLoginData: IUnknown = nil; const AHttpMethod: TGMString = ''; const AUserName: TGMString = ''; const APassword: TGMString = ''; const AReuestContent: ISequentialStream = nil; const AAdditionalHeaders: TGMNameAndStrValArray = []): RGMRequestResult; procedure GMParseHttpStartLine(const AStartLine: TGMString; var AToken1, AToken2, AToken3: TGMString); function GMHttpStatusCodeFromString(const AHttpStatusCode: TGMString): LongInt; function GMIsHttpSuccessStatus(const AStatusCode: LongInt): Boolean; overload; function GMBuildHttpErrorMsg(const AHttpStatusCode: LongInt; const AReason: TGMString): TGMString; function GMHttpStatusMsg(const AHttpStatusCode: LongInt): TGMString; function GMHttpShortHint(const AHttpStatusCode: LongInt): TGMString; procedure GMBuildMultiPartFormContent(const AValues: IGMIntfCollection; const ADest: ISequentialStream; const AMultiPartBoundary: AnsiString); function GMExecHttpPostValues(const AValues: IGMIntfCollection; const AUri: TGMString; const AAskCanceled: IUnknown = nil; const AAskLoginData: IUnknown = nil; const ACertificateData: AnsiString = ''; const AUserName: TGMString = ''; const APassword: TGMString = ''): RGMRequestResult; function GMCharCodingOfContent(const AContent: IUnknown; const ADefaultCharKind: TGMCharKind = ckUnknown): TGMCharKind; //function GMParseHttpUri(const AUri: TGMString): RGMUriComponents; function GMParseHttpStatusLine(const AResponseStatusLine: TGMString): RGMResponseHttpStaus; //procedure AssignHttpDfltPort(var AUriComponents: RGMUriComponents); //function InternetTimeToSystemTimeA(lpszTime: PAnsiChar; out pst: TSystemTime; dwReserved: DWORD): BOOL; stdcall; external cStrWinINetDLL name 'InternetTimeToSystemTimeA'; //function InternetTimeToSystemTimeW(lpszTime: PWideChar; out pst: TSystemTime; dwReserved: DWORD): BOOL; stdcall; external cStrWinINetDLL name 'InternetTimeToSystemTimeW'; // // routines from WinHttp.DLL // type WINHTTP_CURRENT_USER_IE_PROXY_CONFIG = record fAutoDetect: BOOL; lpszAutoConfigUrl: LPWSTR; lpszProxy: LPWSTR; lpszProxyBypass: LPWSTR; end; PWINHTTP_CURRENT_USER_IE_PROXY_CONFIG = ^WINHTTP_CURRENT_USER_IE_PROXY_CONFIG; TWinHttpCurrentUserIEProxyConfig = WINHTTP_CURRENT_USER_IE_PROXY_CONFIG; PWinHttpCurrentUserIEProxyConfig = ^TWinHttpCurrentUserIEProxyConfig; function WinHttpGetIEProxyConfigForCurrentUser(pProxyConfig: PWinHttpCurrentUserIEProxyConfig): BOOL; stdcall; //function WinHttpGetDefaultProxyConfiguration(var pProxyInfo: TWinHttpProxyInfo): BOOL; stdcall; //function WinHttpSetDefaultProxyConfiguration(var pProxyInfo: TWinHttpProxyInfo): BOOL; stdcall; var vDfltHttpProtocolVersion: TGMString = '1.1'; vDfltHttpPort: TGMString = scDfltHttpPort; //vDfltUserAgent: TGMString = 'GM-Http/1.0'; vMaxHttpRedirectCount: LongInt = 5; vMaxHttpReConnectCount: LongInt = 2; vMaxHttpAuthDeniedCount: LongInt = 3; implementation uses SysUtils, GMCharCoding {$IFDEF TLS_SUPPORT},GMOpenSSL{$ENDIF} {$IFDEF JEDIAPI},jwaWinBase{$ENDIF} ; resourcestring srServerResponseNotHttp = 'The Server did not respond with the HTTP protocol'; srUnknownHTTPStatusCodeFmt = 'Unknown HTTP status code (%d)'; srHTTPStatusErrorFmt = 'HTTP error %d'; //RStrHttpHeaderNotFoundFmt = 'Http header "%s" not found'; srHttpAuthSchmeNotImplFmt = 'Http authentication scheme(s) [%s] not implemented'; srNoAuthSchemeProvidedByServer = 'The Server has not provided any "%s" header to tell which authentication scheme it is willing to accept'; //RStrHttpAuthSchemeChangeFmt = 'Http authentication scheme changed from "%s" to "%s"'; RStr_HTTP_STATUS_CONTINUE = 'The request can be continued'; RStr_HTTP_STATUS_SWITCH_PROTOCOLS = 'The server has switched protocols in an upgrade header'; RStr_HTTP_STATUS_OK = 'The request completed successfully'; RStr_HTTP_STATUS_CREATED = 'The request has been fulfilled and resulted in the creation of a new resource'; RStr_HTTP_STATUS_ACCEPTED = 'The request has been accepted for processing, but the processing has not been completed'; RStr_HTTP_STATUS_PARTIAL = 'The returned meta information in the entity-header is not the definitive set available from the origin server'; RStr_HTTP_STATUS_NO_CONTENT = 'The server has fulfilled the request, but there is no new information to send back'; RStr_HTTP_STATUS_RESET_CONTENT = 'The request has been completed, and the client program should reset the document view that caused the request to be sent to allow the user to easily initiate another input action'; RStr_HTTP_STATUS_PARTIAL_CONTENT = 'The server has fulfilled the partial GET request for the resource'; RStr_HTTP_STATUS_AMBIGUOUS = 'The server couldn''t decide what to return'; RStr_HTTP_STATUS_MOVED = 'The requested resource has been assigned to a new permanent URI (Uniform Resource Identifier), and any future references to this resource should be done using one of the returned URIs'; RStr_HTTP_STATUS_REDIRECT = 'The requested resource resides temporarily under a different URI (Uniform Resource Identifier)'; RStr_HTTP_STATUS_REDIRECT_METHOD = 'The response to the request can be found under a different URI (Uniform Resource Identifier) and should be retrieved using a GET method on that resource'; RStr_HTTP_STATUS_NOT_MODIFIED = 'The requested resource has not been modified'; RStr_HTTP_STATUS_USE_PROXY = 'The requested resource must be accessed through the proxy given by the location field'; RStr_HTTP_STATUS_REDIRECT_KEEP_VERB = 'The redirected request keeps the same verb. HTTP/1.1 behavior'; RStr_HTTP_STATUS_BAD_REQUEST = 'The request could not be processed by the server due to invalid syntax'; RStr_HTTP_STATUS_DENIED = 'The requested resource requires user authentication'; RStr_HTTP_STATUS_PAYMENT_REQ = 'Not currently implemented in the HTTP protocol'; RStr_HTTP_STATUS_FORBIDDEN = 'The server understood the request, but is refusing to fulfill it'; RStr_HTTP_STATUS_NOT_FOUND = 'The server has not found anything matching the requested URI (Uniform Resource Identifier)'; RStr_HTTP_STATUS_BAD_METHOD = 'The method used is not allowed'; RStr_HTTP_STATUS_NONE_ACCEPTABLE = 'No responses acceptable to the client were found'; RStr_HTTP_STATUS_PROXY_AUTH_REQ = 'Proxy authentication required'; RStr_HTTP_STATUS_REQUEST_TIMEOUT = 'The server timed out waiting for the request'; RStr_HTTP_STATUS_CONFLICT = 'The request could not be completed due to a conflict with the current state of the resource. The user should resubmit with more information'; RStr_HTTP_STATUS_GONE = 'The requested resource is no longer available at the server, and no forwarding address is known'; //RStr_HTTP_STATUS_AUTH_REFUSED = 'The server refuses to accept the request without a defined content length'; RStr_HTTP_STATUS_LENGTH_REQUIRED = 'the server refused to accept request without a length'; RStr_HTTP_STATUS_PRECOND_FAILED = 'The precondition given in one or more of the request header fields evaluated to false when it was tested on the server'; RStr_HTTP_STATUS_REQUEST_TOO_LARGE = 'The server is refusing to process a request because the request entity is larger than the server is willing or able to process'; RStr_HTTP_STATUS_URI_TOO_LONG = 'The server is refusing to service the request because the request URI (Uniform Resource Identifier) is longer than the server is willing to interpret'; RStr_HTTP_STATUS_UNSUPPORTED_MEDIA = 'The server is refusing to service the request because the entity of the request is in a format not supported by the requested resource for the requested method'; RStr_HTTP_STATUS_RETRY_WITH = 'The request should be retried after doing the appropriate action'; RStr_HTTP_STATUS_SERVER_ERROR = 'The server encountered an unexpected condition that prevented it from fulfilling the request'; RStr_HTTP_STATUS_NOT_SUPPORTED = 'The server does not support the functionality required to fulfill the request'; RStr_HTTP_STATUS_BAD_GATEWAY = 'The server, while acting as a gateway or proxy, received an invalid response from the upstream server it accessed in attempting to fulfill the request'; RStr_HTTP_STATUS_SERVICE_UNAVAIL = 'The service is temporarily overloaded'; RStr_HTTP_STATUS_GATEWAY_TIMEOUT = 'The request was timed out waiting for a gateway'; RStr_HTTP_STATUS_VERSION_NOT_SUP = 'The server does not support, or refuses to support, the HTTP protocol version that was used in the request message'; RStr_HTTP_STATUS_PROCESSING = 'Request is still processing'; RStr_HTTP_MULTI_STATUS = 'Multiple http stati returned'; RStr_HTTP_STATUS_UNPROCESSABLE_ENTITY = 'The request contains semantically erroneous instructions'; RStr_HTTP_STATUS_LOCKED = 'The requested resource is locked'; RStr_HTTP_STATUS_FAILED_DEPENDENCY = 'An operation that this request depends on failed'; RStr_HTTP_STATUS_INSUFFICIENT_STORAGE = 'Not enough storage'; srInvalidHttpChunkTerm = 'Invalid http chunk terminator'; srTheProtocolObj = 'The protocol object'; srTranspoerLayerNotConnected = 'Network transport layer not connected'; srTooManyRedirects = 'Too many http redirections: %d'; srTooManyReconnects = 'Too many http re-connects: %d'; srNoRedirectionUri = 'Http redirection URI is empty'; srNoUri = 'No URI specified'; srUnsupportedDecoding = 'HTTP Transfer-Encoding not supported: "%s"'; {$IFDEF TLS_SUPPORT} srNTLMServerChallengeMsgMissing = 'NTLM server challenge header missing'; srInvalidNTLMProtocolName = 'Inconsistent NTLM protocol name: "%s"'; srInvalidNTLMMsgKind = 'Invalid NTLM protocol message kind: %d'; srInvalidNTLMAuthState = 'Inavlid NTLM authentication state: %d'; {$ENDIF} var vCSRegisterHttpClientAuthHanlderClasses: IGMCriticalSection = nil; vCSRegisterHttpTransferDecoders: IGMCriticalSection = nil; type IGMGetHttpClientAuthSchemeHandlerClass = interface(IUnknown) ['{AC34FE4B-187F-4B1B-A800-B0655D3742CB}'] function GetAuthSchemeHandlerClass: TGMHttpClientAuthenticationHandlerClass; end; TGMHttpClientAuthSchemeHandlerClassEntry = class(TGMRefCountedObj, IGMGetName, IGMGetPosition, IGMGetHttpClientAuthSchemeHandlerClass) protected FPosition: PtrInt; FAuthSchemeName: TGMString; FAuthSchemeHandlerClass: TGMHttpClientAuthenticationHandlerClass; public constructor Create(const AAuthSchmeName: TGMString; const APosition: PtrInt; const AAuthSchmeHandlerClass: TGMHttpClientAuthenticationHandlerClass; const ARefLifeTime: Boolean = True); reintroduce; function GetName: TGMString; stdcall; function GetPosition: PtrInt; stdcall; function GetAuthSchemeHandlerClass: TGMHttpClientAuthenticationHandlerClass; end; IGMHttpTransferDecoder = Interface(IUnknown) ['{8221BEA2-1CDE-450B-9002-B096E42C4ABA}'] function CreateDecodeStream(const ARequest: TGMHttpRequestBase; const ASourceStream: ISequentialStream): ISequentialStream; end; TGMHttpTransferDecoderBase = class(TGMRefCountedObj, IGMGetName, IGMHttpTransferDecoder) protected FHttpTokenName: TGMString; public constructor Create(const AHttpTokenName: TGMString; const ARefLifeTime: Boolean = True); reintroduce; function GetName: TGMString; stdcall; function CreateDecodeStream(const ARequest: TGMHttpRequestBase; const ASourceStream: ISequentialStream): ISequentialStream; virtual; abstract; end; TGMHttpChunckedTransferDecoder = class(TGMHttpTransferDecoderBase) public function CreateDecodeStream(const ARequest: TGMHttpRequestBase; const ASourceStream: ISequentialStream): ISequentialStream; override; end; {$IFDEF HTTP_ZIP_SUPPORT} TGMHttpZIPTransferDecoder = class(TGMHttpTransferDecoderBase) public function CreateDecodeStream(const ARequest: TGMHttpRequestBase; const ASourceStream: ISequentialStream): ISequentialStream; override; end; {$ENDIF} var vHttpClientAuthHandlerClasses: IGMIntfCollection = nil; vHttpTransferDecoders: IGMIntfCollection = nil; { ------------------------- } { ---- Global Routines ---- } { ------------------------- } function RegisterHttpClientAuthHanlderClasses: IGMIntfCollection; begin if vCSRegisterHttpClientAuthHanlderClasses <> nil then vCSRegisterHttpClientAuthHanlderClasses.EnterCriticalSection; try if vHttpClientAuthHandlerClasses = nil then begin vHttpClientAuthHandlerClasses := TGMIntfArrayCollection.Create(False, True, GMCompareByName); vHttpClientAuthHandlerClasses.Add(TGMHttpClientAuthSchemeHandlerClassEntry.Create(cHttpAuthBasic, 1, TGMHttpClientBasicAuthenticationHandler)); {$IFDEF TLS_SUPPORT} vHttpClientAuthHandlerClasses.Add(TGMHttpClientAuthSchemeHandlerClassEntry.Create(cHttpAuthNTLM, 2, TGMHttpClientNTLMAuthenticationHandler)); {$ENDIF} end; Result := vHttpClientAuthHandlerClasses; finally if vCSRegisterHttpClientAuthHanlderClasses <> nil then vCSRegisterHttpClientAuthHanlderClasses.LeaveCriticalSection; end; end; function RegisterHttpTransferDecoders: IGMIntfCollection; begin if vCSRegisterHttpTransferDecoders <> nil then vCSRegisterHttpTransferDecoders.EnterCriticalSection; try if vHttpTransferDecoders = nil then begin vHttpTransferDecoders := TGMIntfArrayCollection.Create(False, True, GMCompareByName); vHttpTransferDecoders.Add(TGMHttpChunckedTransferDecoder.Create(cHttpChunked, True)); {$IFDEF HTTP_ZIP_SUPPORT} vHttpTransferDecoders.Add(TGMHttpZIPTransferDecoder.Create(cHttpDeflate, True)); vHttpTransferDecoders.Add(TGMHttpZIPTransferDecoder.Create(cHttpGZip, True)); {$ENDIF} end; Result := vHttpTransferDecoders; finally if vCSRegisterHttpTransferDecoders <> nil then vCSRegisterHttpTransferDecoders.LeaveCriticalSection; end; end; function GMHttpStatusMsg(const AHttpStatusCode: LongInt): TGMString; begin case AHttpStatusCode of HTTP_STATUS_CONTINUE: Result := RStr_HTTP_STATUS_CONTINUE; HTTP_STATUS_SWITCH_PROTOCOLS: Result := RStr_HTTP_STATUS_SWITCH_PROTOCOLS; HTTP_STATUS_OK: Result := RStr_HTTP_STATUS_OK; HTTP_STATUS_CREATED: Result := RStr_HTTP_STATUS_CREATED; HTTP_STATUS_ACCEPTED: Result := RStr_HTTP_STATUS_ACCEPTED; HTTP_STATUS_PARTIAL: Result := RStr_HTTP_STATUS_PARTIAL; HTTP_STATUS_NO_CONTENT: Result := RStr_HTTP_STATUS_NO_CONTENT; HTTP_STATUS_RESET_CONTENT: Result := RStr_HTTP_STATUS_RESET_CONTENT; HTTP_STATUS_PARTIAL_CONTENT: Result := RStr_HTTP_STATUS_PARTIAL_CONTENT; HTTP_STATUS_AMBIGUOUS: Result := RStr_HTTP_STATUS_AMBIGUOUS; HTTP_STATUS_MOVED: Result := RStr_HTTP_STATUS_MOVED; HTTP_STATUS_REDIRECT: Result := RStr_HTTP_STATUS_REDIRECT; HTTP_STATUS_REDIRECT_METHOD: Result := RStr_HTTP_STATUS_REDIRECT_METHOD; HTTP_STATUS_NOT_MODIFIED: Result := RStr_HTTP_STATUS_NOT_MODIFIED; HTTP_STATUS_USE_PROXY: Result := RStr_HTTP_STATUS_USE_PROXY; HTTP_STATUS_REDIRECT_KEEP_VERB: Result := RStr_HTTP_STATUS_REDIRECT_KEEP_VERB; HTTP_STATUS_BAD_REQUEST: Result := RStr_HTTP_STATUS_BAD_REQUEST; HTTP_STATUS_DENIED: Result := RStr_HTTP_STATUS_DENIED; HTTP_STATUS_PAYMENT_REQ: Result := RStr_HTTP_STATUS_PAYMENT_REQ; HTTP_STATUS_FORBIDDEN: Result := RStr_HTTP_STATUS_FORBIDDEN; HTTP_STATUS_NOT_FOUND: Result := RStr_HTTP_STATUS_NOT_FOUND; HTTP_STATUS_BAD_METHOD: Result := RStr_HTTP_STATUS_BAD_METHOD; HTTP_STATUS_NONE_ACCEPTABLE: Result := RStr_HTTP_STATUS_NONE_ACCEPTABLE; HTTP_STATUS_PROXY_AUTH_REQ: Result := RStr_HTTP_STATUS_PROXY_AUTH_REQ; HTTP_STATUS_REQUEST_TIMEOUT: Result := RStr_HTTP_STATUS_REQUEST_TIMEOUT; HTTP_STATUS_CONFLICT: Result := RStr_HTTP_STATUS_CONFLICT; HTTP_STATUS_GONE: Result := RStr_HTTP_STATUS_GONE; HTTP_STATUS_LENGTH_REQUIRED: Result := RStr_HTTP_STATUS_LENGTH_REQUIRED; HTTP_STATUS_PRECOND_FAILED: Result := RStr_HTTP_STATUS_PRECOND_FAILED; HTTP_STATUS_REQUEST_TOO_LARGE: Result := RStr_HTTP_STATUS_REQUEST_TOO_LARGE; HTTP_STATUS_URI_TOO_LONG: Result := RStr_HTTP_STATUS_URI_TOO_LONG; HTTP_STATUS_UNSUPPORTED_MEDIA: Result := RStr_HTTP_STATUS_UNSUPPORTED_MEDIA; HTTP_STATUS_RETRY_WITH: Result := RStr_HTTP_STATUS_RETRY_WITH; HTTP_STATUS_SERVER_ERROR: Result := RStr_HTTP_STATUS_SERVER_ERROR; HTTP_STATUS_NOT_SUPPORTED: Result := RStr_HTTP_STATUS_NOT_SUPPORTED; HTTP_STATUS_BAD_GATEWAY: Result := RStr_HTTP_STATUS_BAD_GATEWAY; HTTP_STATUS_SERVICE_UNAVAIL: Result := RStr_HTTP_STATUS_SERVICE_UNAVAIL; HTTP_STATUS_GATEWAY_TIMEOUT: Result := RStr_HTTP_STATUS_GATEWAY_TIMEOUT; HTTP_STATUS_VERSION_NOT_SUP: Result := RStr_HTTP_STATUS_VERSION_NOT_SUP; HTTP_STATUS_PROCESSING: Result := RStr_HTTP_STATUS_PROCESSING; HTTP_MULTI_STATUS: Result := RStr_HTTP_MULTI_STATUS; HTTP_STATUS_UNPROCESSABLE_ENTITY: Result := RStr_HTTP_STATUS_UNPROCESSABLE_ENTITY; HTTP_STATUS_LOCKED: Result := RStr_HTTP_STATUS_LOCKED; HTTP_STATUS_FAILED_DEPENDENCY: Result := RStr_HTTP_STATUS_FAILED_DEPENDENCY; HTTP_STATUS_INSUFFICIENT_STORAGE: Result := RStr_HTTP_STATUS_INSUFFICIENT_STORAGE; else Result := GMFormat(srUnknownHTTPStatusCodeFmt, [AHttpStatusCode]); end; end; function GMHttpShortHint(const AHttpStatusCode: LongInt): TGMString; begin case AHttpStatusCode of HTTP_STATUS_CONTINUE: Result := 'CONTINUE'; HTTP_STATUS_SWITCH_PROTOCOLS: Result := 'SWITCH PROTOCOLS'; HTTP_STATUS_OK: Result := 'OK'; HTTP_STATUS_CREATED: Result := 'CREATED'; HTTP_STATUS_ACCEPTED: Result := 'ACCEPTED'; HTTP_STATUS_PARTIAL: Result := 'PARTIAL'; HTTP_STATUS_NO_CONTENT: Result := 'NO CONTENT'; HTTP_STATUS_RESET_CONTENT: Result := 'RESET CONTENT'; HTTP_STATUS_PARTIAL_CONTENT: Result := 'PARTIAL CONTENT'; HTTP_STATUS_AMBIGUOUS: Result := 'AMBIGUOUS'; HTTP_STATUS_MOVED: Result := 'MOVED'; HTTP_STATUS_REDIRECT: Result := 'REDIRECT'; HTTP_STATUS_REDIRECT_METHOD: Result := 'REDIRECT METHOD'; HTTP_STATUS_NOT_MODIFIED: Result := 'NOT MODIFIED'; HTTP_STATUS_USE_PROXY: Result := 'USE PROXY'; HTTP_STATUS_REDIRECT_KEEP_VERB: Result := 'REDIRECT KEEP VERB'; HTTP_STATUS_BAD_REQUEST: Result := 'BAD REQUEST'; HTTP_STATUS_DENIED: Result := 'DENIED'; HTTP_STATUS_PAYMENT_REQ: Result := 'PAYMENT REQUEST'; HTTP_STATUS_FORBIDDEN: Result := 'FORBIDDEN'; HTTP_STATUS_NOT_FOUND: Result := 'NOT FOUND'; HTTP_STATUS_BAD_METHOD: Result := 'BAD METHOD'; HTTP_STATUS_NONE_ACCEPTABLE: Result := 'NONE ACCEPTABLE'; HTTP_STATUS_PROXY_AUTH_REQ: Result := 'PROXY AUTHENTICATION REQUIRED'; HTTP_STATUS_REQUEST_TIMEOUT: Result := 'REQUEST TIMEOUT'; HTTP_STATUS_CONFLICT: Result := 'CONFLICT'; HTTP_STATUS_GONE: Result := 'GONE'; HTTP_STATUS_LENGTH_REQUIRED: Result := 'LENGTH REQUIRED'; HTTP_STATUS_PRECOND_FAILED: Result := 'PRECOND FAILED'; HTTP_STATUS_REQUEST_TOO_LARGE: Result := 'REQUEST TOO LARGE'; HTTP_STATUS_URI_TOO_LONG: Result := 'URI TOO LONG'; HTTP_STATUS_UNSUPPORTED_MEDIA: Result := 'UNSUPPORTED MEDIA'; HTTP_STATUS_RETRY_WITH: Result := 'RETRY WITH'; HTTP_STATUS_SERVER_ERROR: Result := 'SERVER ERROR'; HTTP_STATUS_NOT_SUPPORTED: Result := 'NOT SUPPORTED'; HTTP_STATUS_BAD_GATEWAY: Result := 'BAD GATEWAY'; HTTP_STATUS_SERVICE_UNAVAIL: Result := 'SERVICE UNAVAILABLE'; HTTP_STATUS_GATEWAY_TIMEOUT: Result := 'GATEWAY TIMEOUT'; HTTP_STATUS_VERSION_NOT_SUP: Result := 'VERSION NOT SUPPORTED'; HTTP_STATUS_PROCESSING: Result := 'PROCESSING'; HTTP_MULTI_STATUS: Result := 'MULTI STATUS'; HTTP_STATUS_UNPROCESSABLE_ENTITY: Result := 'UNPROCESSABLE ENTITY'; HTTP_STATUS_LOCKED: Result := 'LOCKED'; HTTP_STATUS_FAILED_DEPENDENCY: Result := 'FAILED DEPENDENCY'; HTTP_STATUS_INSUFFICIENT_STORAGE: Result := 'INSUFFICIENT STORAGE'; else Result := 'UNKNOWN'; end; end; //function GMParseHttpUri(const AUri: TGMString): RGMUriComponents; //begin // Result := GMParseUri(AUri); // //if Length(Result.Port) <= 0 then // // if GMSameText(Result.Scheme, scStrHttps) then Result.Port := scDfltHttpsPort; //end; //procedure AssignHttpDfltPort(var AUriComponents: RGMUriComponents); //begin // if Length(AUriComponents.Port) <= 0 then // if GMSameText(AUriComponents.Scheme, scStrHttps) then AUriComponents.Port := scDfltHttpsPort; //end; function GMMakeHttpHResult(const AHttpErrorCode: LongInt): HResult; begin Result := cCustomHrError or (FACILITY_GM_HTTP shl 16) or AHttpErrorCode; end; function GMExtractHttpCodeFromHResult(const AHResult: HResult; const ADefaultCode: LongInt): LongInt; begin if AHResult and LongInt($FFFF0000) = (cCustomHrError or (FACILITY_GM_HTTP shl 16)) then Result := AHResult and $0000FFFF else Result := ADefaultCode; end; //function GMExtractHttpCodeFromHResult(const AHrCode: HResult): LongWord; //begin //if ((AHrCode and cCustomHrError) <> 0) and (((AHrCode and $07FF0000) shr 16) = FACILITY_GM_HTTP) then // Result := AHrCode and $0000FFFF else Result := 0; //end; function GMBuildHttpErrorMsg(const AHttpStatusCode: LongInt; const AReason: TGMString): TGMString; var msg: TGMString; begin msg := GMHttpStatusMsg(AHttpStatusCode); if Length(msg) > 0 then Result := GMStringJoin(GMStringJoin(GMFormat(srHTTPStatusErrorFmt, [AHttpStatusCode]), ', ', AReason), ', ', msg) else Result := GMStringJoin(GMFormat(srUnknownHTTPStatusCodeFmt, [AHttpStatusCode]), ': ', AReason); end; procedure GMParseHttpStartLine(const AStartLine: TGMString; var AToken1, AToken2, AToken3: TGMString); var chPos: PtrInt; begin chPos := 1; AToken1 := GMNextWord(chPos, AStartLine, cWhiteSpace); AToken2 := GMNextWord(chPos, AStartLine, cWhiteSpace); AToken3 := Copy(AStartLine, chPos, Length(AStartLine) - chPos + 1); end; function GMHttpStatusCodeFromString(const AHttpStatusCode: TGMString): LongInt; begin Result := GMStrToInt(GMMakeDezInt(AHttpStatusCode, cDfltHttpErrorCode)); end; function GMParseHttpStatusLine(const AResponseStatusLine: TGMString): RGMResponseHttpStaus; var statusCodeStr: TGMString; begin GMParseHttpStartLine(AResponseStatusLine, Result.HttpVersion, statusCodeStr, Result.ReasonText); Result.StatusCode := GMHttpStatusCodeFromString(statusCodeStr); end; function GMIsHttpSuccessStatus(const AStatusCode: LongInt): Boolean; begin Result := (AStatusCode >= 200) and (AStatusCode < 300); end; function GMExecuteHttpRequest(const AUri: TGMString; const AAskCanceled, AAskLoginData: IUnknown; const AHttpMethod, AUserName, APassword: TGMString; const AReuestContent: ISequentialStream; const AAdditionalHeaders: TGMNameAndStrValArray): RGMRequestResult; var session: IGMHttpClientSession; begin if Length(AUri) <= 0 then raise EGMHttpException.ObjError(srNoUri, nil, 'GMExecuteHttpRequest'); session := TGMHttpClientSession.Create(AAskCanceled, AAskLoginData, nil, AUserName, APassword); //session.ConnectTransportLayer(uriParts.Scheme, uriParts.Host, uriParts.Port); // // The Session will be destructed by the scope of this routine, but underlying soketIO // (FTransportLayerConnection member of the session) is still hold by references inside the streams returned! // // GMBuildUri('', '', '', '', '', uriParts.Path, uriParts.Query, uriParts.Fragment) Result := session.ExecuteRequest(nil, AUri, AHttpMethod, AReuestContent, AAdditionalHeaders); end; procedure GMBuildMultiPartFormContent(const AValues: IGMIntfCollection; const ADest: ISequentialStream; const AMultiPartBoundary: AnsiString); var it: IGMIterator; unkElement, posKeeper: IUnknown; name: IGMGetName; value: IGMGetStringValue; token: AnsiString; begin if (AValues = nil) or (ADest = nil) then Exit; posKeeper := TGMIStreamPosKeeper.Create(ADest); it := AValues.CreateIterator; while it.NextEntry(unkElement) do if GMQueryInterface(unkElement, IGMGetName, name) and GMQueryInterface(unkElement, IGMGetStringValue, value) then begin token := '--' + AMultiPartBoundary + CRLF; GMSafeIStreamWrite(ADest, PAnsiChar(token), Length(token)); token := 'content-disposition: '+cMimeFormData+'; name="'+name.Name+'"' + CRLF; GMSafeIStreamWrite(ADest, PAnsiChar(token), Length(token)); token := 'content-type: text/plain; charset=utf-8' + CRLF; GMSafeIStreamWrite(ADest, PAnsiChar(token), Length(token)); token := 'content-transfer-encoding: binary' + CRLF + CRLF; GMSafeIStreamWrite(ADest, PAnsiChar(token), Length(token)); token := GMStringToUtf8(value.StringValue) + CRLF; GMSafeIStreamWrite(ADest, PAnsiChar(token), Length(token)); end; token := '--' + AMultiPartBoundary + '--'; GMSafeIStreamWrite(ADest, PAnsiChar(token), Length(token)); end; function GMExecHttpPostValues(const AValues: IGMIntfCollection; const AUri: TGMString; const AAskCanceled: IUnknown; const AAskLoginData: IUnknown; const ACertificateData: AnsiString; const AUserName: TGMString; const APassword: TGMString): RGMRequestResult; var session: IGMHttpClientSession; requestContent: ISequentialStream; multiPartBoundary: AnsiString; begin if Length(AUri) <= 0 then raise EGMHttpException.ObjError(srNoUri, nil, 'GMExecHttpPostValues'); session := TGMHttpClientSession.Create(AAskCanceled, AAskLoginData, nil, AUserName, APassword, nil, ACertificateData); multiPartBoundary := 'C3006447922B4499997877A2E5CB41E5'; requestContent := TGMAnsiStringIStream.Create; GMBuildMultiPartFormContent(AValues, requestContent, multiPartBoundary); //session.ConnectTransportLayer(uriParts.Scheme, uriParts.Host, uriParts.Port); Result := session.ExecuteRequest(nil, AUri, // GMBuildUri('', '', '', '', '', uriParts.Path, uriParts.Query, uriParts.Fragment), cHttpMethodPOST, requestContent, [InitRGMNameAndStrValue('Content-Type', cMimeMultiPart+'/'+cMimeFormData+'; boundary='+multiPartBoundary)]); //'Content-Type: '+cMimeMultiPart+'/'+cMimeFormData+'; boundary='+multiPartBoundary]); end; function GMCharCodingOfContent(const AContent: IUnknown; const ADefaultCharKind: TGMCharKind = ckUnknown): TGMCharKind; var contentInfo: IGMHttpContentInfo; begin if not GMQueryInterface(AContent, IGMHttpContentInfo, contentInfo) then Result := ADefaultCharKind else Result := GMCharCodingOfContentType(contentInfo.ContentType, ADefaultCharKind); end; function GMHttpHostHeader(const AUri: RGMUriComponents): TGMString; var prt: TGMString; begin Result := AUri.Host; if Length(Result) <= 0 then Exit; if IsIP6Address(Result) then Result := '[' + Result+ ']'; prt := ''; if (Length(AUri.Port) > 0) and not GMSameText(AUri.Port, scDfltHttpPort) then prt := AUri.Port; if (Length(AUri.Port) <= 0) and GMSameText(AUri.Scheme, scStrHttps) then prt := scDfltHttpsPort; if Length(prt) > 0 then Result := Result + ':' + prt; end; { -------------------------- } { ---- EGMHttpException ---- } { -------------------------- } constructor EGMHttpException.HttpError(const AHttpStatusCode: LongInt; const AReason, APostFix: TGMString; const ACaller: TObject; const ACallingName: TGMString); begin FErrorCode := AHttpStatusCode; ObjError(GMStringJoin(GMBuildHttpErrorMsg(AHttpStatusCode, AReason), c2NewLine, GMStrip(APostFix)), ACaller, ACallingName); end; function EGMHttpException.GetHRCode: HResult; begin Result := GMMakeHttpHResult(FErrorCode); end; { -------------------------------------------------- } { ---- TGMHttpClientAuthSchemeHandlerClassEntry ---- } { -------------------------------------------------- } constructor TGMHttpClientAuthSchemeHandlerClassEntry.Create(const AAuthSchmeName: TGMString; const APosition: PtrInt; const AAuthSchmeHandlerClass: TGMHttpClientAuthenticationHandlerClass; const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FPosition := APosition; FAuthSchemeName := AAuthSchmeName; FAuthSchemeHandlerClass := AAuthSchmeHandlerClass; end; function TGMHttpClientAuthSchemeHandlerClassEntry.GetName: TGMString; begin Result := FAuthSchemeName; end; function TGMHttpClientAuthSchemeHandlerClassEntry.GetPosition: PtrInt; begin Result := FPosition; end; function TGMHttpClientAuthSchemeHandlerClassEntry.GetAuthSchemeHandlerClass: TGMHttpClientAuthenticationHandlerClass; begin Result := FAuthSchemeHandlerClass; end; { ------------------------------------------------ } { ---- TGMHttpClientAuthenticationHandlerBase ---- } { ------------------------------------------------ } constructor TGMHttpClientAuthenticationHandlerBase.Create(const AUseProxy: Boolean; const AUserName, APassword: TGMString; const ARefLifeTime: Boolean); begin Create(ARefLifeTime); FUserName := AUserName; FPassword := APassword; FUseProxy := AUseProxy; end; function TGMHttpClientAuthenticationHandlerBase.AuthorizationHeaderName: TGMString; begin if FUseProxy then Result := cHttpProxyAuthorization else Result := cHttpAuthorization; end; procedure TGMHttpClientAuthenticationHandlerBase.AddAuthorizationHeader(const AHeaders: IGMIntfCollection); begin FLastUserName := FUserName; FLastPassword := FPassword; end; function TGMHttpClientAuthenticationHandlerBase.ProcessAuthDenied(const AResponseHeaders: IGMIntfCollection; const ARetryCount: Integer; const AAskLoginData: IUnknown): Boolean; var getLoginData: IGMGetHttpLoginData; loginData: RGMHttpLoginData; begin if GMQueryInterface(AAskLoginData, IGMGetHttpLoginData, getLoginData) then begin FillByte(loginData, SizeOf(loginData), 0); GMHrCheckObj(getLoginData.GetHttpLoginData(@loginData), Self, 'GetHttpLoginData'); FUserName := loginData.UserName; FPassword := loginData.Password; end; Result := not (GMSameText(FLastUserName, FUserName) and GMSameText(FLastPassword, FPassword)); end; procedure TGMHttpClientAuthenticationHandlerBase.OnTransportLayerDisconnected; begin // Nothing, assuming authtication header stays valid for new connections end; { ------------------------------------------------- } { ---- TGMHttpClientBasicAuthenticationHandler ---- } { ------------------------------------------------- } function TGMHttpClientBasicAuthenticationHandler.AuthSchemeName: TGMString; begin Result := cHttpAuthBasic; end; function TGMHttpClientBasicAuthenticationHandler.ProcessAuthDenied(const AResponseHeaders: IGMIntfCollection; const ARequestRetryCount: Integer; const AAskLoginData: IUnknown): Boolean; begin Result := inherited ProcessAuthDenied(AResponseHeaders, ARequestRetryCount, AAskLoginData); Result := Result and (ARequestRetryCount <= vMaxHttpAuthDeniedCount); end; procedure TGMHttpClientBasicAuthenticationHandler.AddAuthorizationHeader(const AHeaders: IGMIntfCollection); begin if Length(FUserName) > 0 then GMAddINetHeader(AHeaders, AuthorizationHeaderName, cHttpAuthBasic + ' ' + GMEncodeBase64Str(FUserName + ':' + FPassword)); inherited; end; { ------------------------------------------------ } { ---- TGMHttpClientNTLMAuthenticationHandler ---- } { ------------------------------------------------ } {$IFDEF TLS_SUPPORT} function TGMHttpClientNTLMAuthenticationHandler.AuthSchemeName: TGMString; begin Result := cHttpAuthNTLM; end; procedure TGMHttpClientNTLMAuthenticationHandler.OnTransportLayerDisconnected; begin FNTLMAuthSate := 0; NTLMClearServerResponse(FServerResponse); //FServerResponse := Default(TNTLMServerResponse); end; procedure TGMHttpClientNTLMAuthenticationHandler.AddAuthorizationHeader(const AHeaders: IGMIntfCollection); begin case FNTLMAuthSate of 0: ; // <- Nothing! 1: GMAddINetHeader(AHeaders, AuthorizationHeaderName, cHttpAuthNTLM + ' ' + BuildNTLMClientStartMsg); 2: begin GMAddINetHeader(AHeaders, AuthorizationHeaderName, cHttpAuthNTLM + ' ' + BuildNTLMClientCredentialsMsg(FUSerName, FPassword, @FServerResponse)); Inc(FNTLMAuthSate); end; 3: ; // <- Nothing! With NTLM no authentication header needs to be added anymore once the connection is authenticated! else raise EGMHttpException.ObjError(GMFormat(srInvalidNTLMAuthState, [FNTLMAuthSate]), Self, 'AddAuthorizationHeader'); end; end; function TGMHttpClientNTLMAuthenticationHandler.ProcessAuthDenied(const AResponseHeaders: IGMIntfCollection; const ARequestRetryCount: Integer; const AAskLoginData: IUnknown): Boolean; var challengeData: TGMString; function FindServerNtlmChallengeData(const AResponseHeaders: IGMIntfCollection): TGMString; var headerIt: IGMIterator; unkHeader: IUnknown; getStrVal: IGMGetStringValue; hdrStrVal, token: TGMString; chPos: PtrInt; begin Result := ''; if AResponseHeaders = nil then Exit; headerIt := TGMInetHeaderIterator.Create(AResponseHeaders.CreateIterator, cAuthenticateHeaderName[FUseProxy]); while headerIt.NextEntry(unkHeader) do if GMQueryInterface(unkHeader, IGMGetStringValue, getStrVal) then begin hdrStrVal := getStrVal.StringValue; chPos := 1; token := GMNextWord(chPos, hdrStrVal, ' '); if GMSameText(token, 'NTLM') then begin Result := GMStrip(Copy(hdrStrVal, chPos, Length(hdrStrVal) - chPos + 1)); if Length(Result) > 0 then Break; end; end; end; begin Result := True; case FNTLMAuthSate of 0: begin Inc(FNTLMAuthSate); NTLMClearServerResponse(FServerResponse); end; 1: begin Inc(FNTLMAuthSate); Result := inherited ProcessAuthDenied(AResponseHeaders, ARequestRetryCount, AAskLoginData); if Result and (AResponseHeaders <> nil) then begin challengeData := FindServerNtlmChallengeData(AResponseHeaders); if Length(challengeData) <= 0 then raise EGMHttpException.ObjError(srNTLMServerChallengeMsgMissing, Self, {$I %CurrentRoutine%}); FServerResponse := DecodeNTLMServerChallengeMsg(challengeData); // if not CompareMem(PAnsiChar(cStrNTLMProtocolSignature), @FServerResponse.Protocol, Min(Length(cStrNTLMProtocolSignature), SizeOf(FServerResponse.Protocol))) then if not CompareMem(PAnsiChar(cStrNTLMProtocolSignature), PAnsiChar(FServerResponse.Protocol), Min(Length(cStrNTLMProtocolSignature), Length(FServerResponse.Protocol)+1)) then // if FServerResponse.Protocol <> cStrNTLMProtocolSignature then raise EGMHttpException.ObjError(GMFormat(srInvalidNTLMProtocolName, [FServerResponse.Protocol]), Self, {$I %CurrentRoutine%}); if FServerResponse.MSgKind <> 2 then raise EGMHttpException.ObjError(GMFormat(srInvalidNTLMMsgKind, [Integer(FServerResponse.MSgKind)]), Self, {$I %CurrentRoutine%}); end; end; 3: begin FNTLMAuthSate := 0; NTLMClearServerResponse(FServerResponse); Result := False; end; // 3: FNTLMAuthSate := 0; else Result := False; end; end; {$ENDIF} { ------------------------------------ } { ---- TGMHttpTransferDecoderBase ---- } { ------------------------------------ } constructor TGMHttpTransferDecoderBase.Create(const AHttpTokenName: TGMString; const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FHttpTokenName := AHttpTokenName; end; function TGMHttpTransferDecoderBase.GetName: TGMString; stdcall; begin Result := FHttpTokenName; end; //function TGMHttpTransferDecoderBase.CreateDecodeStream(const ASourceStream: ISequentialStream): ISequentialStream; //begin // Result := nil; //end; { ---------------------------------------- } { ---- TGMHttpChunckedTransferDecoder ---- } { ---------------------------------------- } function TGMHttpChunckedTransferDecoder.CreateDecodeStream(const ARequest: TGMHttpRequestBase; const ASourceStream: ISequentialStream): ISequentialStream; begin Result := TGMHttpChunkedStream.CreateRead(ARequest, ASourceStream); end; { --------------------------------------- } { ---- TGMHttpDeflateTransferDecoder ---- } { --------------------------------------- } {$IFDEF HTTP_ZIP_SUPPORT} function TGMHttpZIPTransferDecoder.CreateDecodeStream(const ARequest: TGMHttpRequestBase; const ASourceStream: ISequentialStream): ISequentialStream; begin Result := TGMHttpZipDecompressorIStream.Create(ASourceStream, True); end; {$ENDIF} { ---------------------------- } { ---- TGMHttpRequestBase ---- } { ---------------------------- } function TGMHttpRequestBase.ProtocolDisplayName: TGMString; begin if FUsingTlsLayer then Result := GMUpperCase(scStrHttps) else Result := GMUpperCase(scStrHttp); end; //function TGMHttpRequestBase.IsChunkedTransfer(const AHeaders: IGMIntfCollection): Boolean; //var hdrValue: TGMString; //begin // hdrValue := GMGetINetHeaderStrValue(AHeaders, cHttpTransferEncoding); // Result := GMHasToken(hdrValue, cHttpChunked, cStrINetHeaderWordSeparators); //end; { ---------------------------- } { ---- TGMHttpProxyConfig ---- } { ---------------------------- } constructor TGMHttpProxyConfig.Create(const AProxyHostUri, AProxyBypass, AUsername, APassword: TGMString; const ARefLifeTime: Boolean); begin Create(ARefLifeTime); FProxyHostUri := AProxyHostUri; FProxyBypass := AProxyBypass; FUsername := AUsername; FPassword := APassword; end; procedure TGMHttpProxyConfig.LoadSystemProxySettingsOfCurrentUser; var winProxyConfig: TWinHttpCurrentUserIEProxyConfig; begin winProxyConfig := Default(TWinHttpCurrentUserIEProxyConfig); GMAPICheckObj('WinHttpGetIEProxyConfigForCurrentUser', '', GetLastError, WinHttpGetIEProxyConfigForCurrentUser(@winProxyConfig), Self); FProxyHostUri := winProxyConfig.lpszProxy; FProxyBypass := winProxyConfig.lpszProxyBypass; end; function TGMHttpProxyConfig.GetProxyHostUri: TGMString; begin Result := FProxyHostUri; end; procedure TGMHttpProxyConfig.SetProxyHostUri(const AUri: TGMString); begin FProxyHostUri := AUri; end; function TGMHttpProxyConfig.GetProxyBypass: TGMString; begin Result := FProxyBypass; end; procedure TGMHttpProxyConfig.SetProxyBypass(const ABypass: TGMString); begin FProxyBypass := ABypass; end; function TGMHttpProxyConfig.GetUsername: TGMString; begin Result := FUsername; end; procedure TGMHttpProxyConfig.SetUsername(const AUsername: TGMString); begin FUsername := AUsername; end; function TGMHttpProxyConfig.GetPassword: TGMString; begin Result := FPassword; end; procedure TGMHttpProxyConfig.SetPassword(const APassword: TGMString); begin FPassword := APassword; end; function TGMHttpProxyConfig.UseProxy(const AUri: TGMString): Boolean; var uri: TGMString; chPos: PtrInt; begin if Length(FProxyHostUri) <= 0 then Exit(False); chPos := 1; Result := True; repeat uri := GMNextWord(chPos, FProxyBypass, ';'); {ToDo: implement wildcard URI matching here!} if Length(uri) > 0 then Result := Result and not GMSameText(AUri, uri); until not Result or (Length(uri) <= 0); end; { ------------------------------ } { ---- TGMHttpClientRequest ---- } { ------------------------------ } constructor TGMHttpClientRequest.Create(const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FKeepConnection := True; end; constructor TGMHttpClientRequest.Create(const AAgentName: TGMString; const ARefLifeTime: Boolean); begin Create(ARefLifeTime); FAgentName := AAgentName; end; function TGMHttpClientRequest.Obj: TGMHttpClientRequest; begin Result := Self; end; function TGMHttpClientRequest.ReceiveHeaders(const ATransportLayer: ISequentialStream; const AHeaders: IGMIntfCollection): TGMString; var codingHdrValue: TGMString; len: Int64; begin Result := inherited ReceiveHeaders(ATransportLayer, AHeaders); codingHdrValue := GMGetINetHeaderStrValue(AHeaders, cHttpTransferEncoding); // if additional encodings have been applied, "chunked" MUST be applied too! if GMHasToken(codingHdrValue, cHttpChunked, cStrINetHeaderWordSeparators) then len := cStrmSizeUnlimited else len := GMGetINetHeaderIntValue(AHeaders, cHttpContentLength, cStrmSizeUnlimited); GMSetReadContentSize(ATransportLayer, len); end; function TGMHttpClientRequest.BuildErrorMsgPostfixFromResponseContent(const AResponseContent: ISequentialStream): TGMString; const cMaxLen = 8192; var contentType: String; getAnsiText: IGMGetAnsiText; ansiText: AnsiString; function IsPrintableText(const AText: AnsiString): Boolean; var chIdx: PtrInt; begin Result := Length(AText) > 0; for chIdx:=1 to Length(AText) do if (AText[chIdx] < ' ') and not (AText[chIdx] in [#9, #10, #13]) then Exit(False); end; begin Result := ''; if GMQueryInterface(AResponseContent, IGMGetAnsiText, getAnsiText) then begin contentType := GMGetINetHeaderStrValue(ReceivedHeaders, cHttpContentType); ansiText := Copy(getAnsiText.GetAnsiText, 1, cMaxLen); if IsPrintableText(ansiText) then case GMCharCodingOfContentType(contentType) of ckUtf8: Result := GMUtf8ToString(ansiText); else Result := ansiText; end; end; //Result := inherited BuildErrorMsgPostfixFromResponseContent(AResponseContent); end; function TGMHttpClientRequest.BuildDecodeStreamChain(const ATransportLayer: ISequentialStream): ISequentialStream; var codingHdrVal, token: TGMString; chPos: PtrInt; searchName, foundElement: IUnknown; decoders: IGMIntfCollection; decoder: IGMHttpTransferDecoder; srcStrm: ISequentialStream; begin Result := ATransportLayer; codingHdrVal := GMGetINetHeaderStrValue(ReceivedHeaders, cHttpTransferEncoding); if Length(codingHdrVal) <= 0 then Exit; decoders := RegisterHttpTransferDecoders; if decoders = nil then Exit; chPos := Length(codingHdrVal); repeat token := GMStrip(GMPreviousWord(chPos, codingHdrVal, ',')); if Length(token) <= 0 then Break; searchName := TGMNameObj.Create(GMStrip(GMFirstWord(token, ';'))); if not decoders.Find(searchName, foundElement) then raise EGMHttpException.ObjError(GMFormat(srUnsupportedDecoding, [token]), Self, {$I %CurrentRoutine%}) else begin GMCheckQueryInterface(foundElement, IGMHttpTransferDecoder, decoder, {$I %CurrentRoutine%}); srcStrm := Result; Result := decoder.CreateDecodeStream(Self, srcStrm); end; until False; //if IschunkedTransfer(ReceivedHeaders) then Result := TGMHttpChunkedStream.CreateRead(Self, Result); end; procedure TGMHttpClientRequest.AddStandardHeaders; var nameObj: IUnknown; procedure AddTEHeader; const abnfListSep = ', '; var hdrVal: TGMString; begin hdrval := GMSeparatedNames(RegisterHttpTransferDecoders, abnfListSep); hdrval := GMStringJoin(cHttpTrailers, abnfListSep, hdrval); GMAddINetHeader(HeadersToSend, cHttpTE, hdrval); end; begin //if FUseProxy then cnPrefix := 'Proxy-' else cnPrefix := ''; if FKeepConnection then begin //GMAddINetHeader(HeadersToSend, cHttpConnection, cHttpKeepAlive); // <- In http 1.1 connections are persistent by default! if FKeepConnectionTimeout > 0 then GMAddINetHeader(HeadersToSend, cHttpKeepAlive, FKeepConnectionTimeout); end else begin GMAddINetHeader(HeadersToSend, cHttpConnection, cHttpClose); nameObj := TGMNameObj.Create(cHttpKeepAlive); while HeadersToSend.RemoveByKey(nameObj) do ; end; if Length(FAgentName) > 0 then GMAddINetHeader(HeadersToSend, cHttpUserAgent, FAgentName); AddTEHeader; end; function TGMHttpClientRequest.InternalExecute(const ATransportLayer: ISequentialStream; const AUseProxy: Boolean; const AMethod: TGMString; const AUri: RGMUriComponents; const ARequestContent: ISequentialStream; const AAdditionalHeaders: TGMNameAndStrValArray; const AOnUploadProgressProc: TGMOnProgressProc; const AUploadBuffersize: LongInt; const AUsingTlsLayer: Boolean): RGMRequestResult; var startLine, path, requestContentStr, errMsgPostFix: TGMString; startLineA: AnsiString; contentInfo: IGMHttpContentInfo; responseStatus: RGMResponseHttpStaus; headerEntry: RGMNameAndStrValue; begin Result := Default(RGMRequestResult); Result.Request := Self; FUsingTlsLayer := AUsingTlsLayer; if GMSameText(AMethod, cHttpMethodCONNECT) then path := GMHttpHostHeader(AUri) else if AUseProxy and not AUsingTlsLayer then path := AUri.Uri else path := GMBuildUri('', '', '', '', '', AUri.Path, AUri.Query, AUri.Fragment); startLine := GMUpperCase(GMDeleteChars(AMethod, cWhiteSpace)) + ' ' + path + ' ' + GMUpperCase(scStrHttp) + '/' + vDfltHttpProtocolVersion; AddStandardHeaders; GMAddINetHeader(HeadersToSend, cHttpContentLength, GMIntToStr(GMIStreamSize(ARequestContent)), hamAddIfNew); // <- a PUT request may already have added a content length! for headerEntry in AAdditionalHeaders do GMAddINetHeader(HeadersToSend, headerEntry.Name, headerEntry.StrValue); //if Length(ARequestContentType) > 0 then GMAddINetHeader(HeadersToSend, cHttpContentType, ARequestContentType); startLine := GMStringJoin(startLine, CRLF, GMHeadersAsString(HeadersToSend)) + CRLF + CRLF; vfGMTrace(startLine, ProtocolDisplayName); if vfGMDoTracing then begin requestContentStr := GMGetIntfText(ARequestContent); if Length(requestContentStr) > 0 then vfGMTrace(requestContentStr, cStrContent); end; startLineA := startLine; GMSafeIStreamWrite(ATransportLayer, PAnsiChar(startLineA), Length(startLineA), 'Sending HTTP request headers'); GMCopyIStream(ARequestContent, ATransportLayer, AUploadBufferSize, AOnUploadProgressProc, 'Sending HTTP request content'); responseStatus := GMParseHttpStatusLine(ReceiveHeaders(ATransportLayer, ReceivedHeaders)); // <- dont apply any transfer encoding (chunked etc.) when receiving headers! // ReceiveHeaders will already have set response stream size limit according to the content-length header // Responses to HEAD requests never contain a payload if GMSameText(AMethod, cHttpMethodHEAD) or GMIsOneOfIntegers(responseStatus.StatusCode, [HTTP_STATUS_NO_CONTENT, HTTP_STATUS_NOT_MODIFIED]) then GMSetReadContentSize(ATransportLayer, 0); Result.ResponseContent := BuildDecodeStreamChain(ATransportLayer); if GMQueryInterface(Result.ResponseContent, IGMHttpContentInfo, contentInfo) then begin contentInfo.SetContentType(GMGetINetHeaderStrValue(ReceivedHeaders, cHttpContentType)); contentInfo.SetContentEncoding(GMGetINetHeaderStrValue(ReceivedHeaders, cHttpContentencoding)); end; //CheckResponseStatus(responseStatus, Result.ResponseContent); // <- may consume content, must use chunked stream when headers indicate chunked transfer! if not GMSameText(Copy(responseStatus.HttpVersion, 1, Length(scStrHttp)), scStrHttp) then raise EGMHttpException.ObjError(srServerResponseNotHttp, Self, {$I %CurrentRoutine%}); if not GMIsHttpSuccessStatus(responseStatus.StatusCode) then begin errMsgPostFix := ConsumeContent(Result.ResponseContent); raise EGMHttpException.HttpError(responseStatus.StatusCode, responseStatus.ReasonText, errMsgPostFix, Self, {$I %CurrentRoutine%}); end; end; //procedure TGMHttpClientRequest.CheckResponseStatus(const AResponseStatus: RGMResponseHttpStaus; const AResponseContent: ISequentialStream); //var postFix: TGMString; // statusInt: LongInt; //begin // //GMParseHttpStartLine(AResponseStatus, httpVersion, statusCode, reason); // // if not GMSameText(Copy(AResponseStatus.HttpVersion, 1, Length(scStrHttp)), scStrHttp) then // raise EGMHttpException.ObjError(RStrServerResponseNotHttp, Self, {$I %CurrentRoutine%}); // // //AStatusCode := GMStrToInt(GMMakeDezInt(statusCode, cDfltHttpErrorCode)); // // if not GMIsHttpSuccessStatus(AResponseStatus.StatusCode) then // begin // postFix := ConsumeContent(AResponseContent); // raise EGMHttpException.HttpError(AResponseStatus.StatusCode, reason, postFix, Self, {$I %CurrentRoutine%}); // end; //end; { ------------------------------ } { ---- TGMHttpClientSession ---- } { ------------------------------ } constructor TGMHttpClientSession.Create(const AAskCanceled, AAskLoginData, ACertificateStatusNotifySink: IUnknown; const AUserName: TGMString; const APassword: TGMString; const AProxyConfig: IGMHttpProxyConfig; const ACertificateData: Ansistring; const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FAskCanceled := AAskCanceled; FAskLoginData := AAskLoginData; FCertificateStatusNotifySink := ACertificateStatusNotifySink; FUserName := AUserName; FPassword := APassword; FCertificateData := ACertificateData; FProxyConfig := AProxyConfig; end; destructor TGMHttpClientSession.Destroy; begin if IsTransportLayerConnected then DisconnectTransportLayer; inherited; end; function TGMHttpClientSession.IsTransportLayerConnected: Boolean; begin Result := FTransportLayerConnection <> nil; end; function TGMHttpClientSession.UseProxy(const AUri: TGMSTring): Boolean; begin Result := (FProxyConfig <> nil) and FProxyConfig.UseProxy(AUri); end; procedure TGMHttpClientSession.DisconnectTransportLayer; begin if FTransportLayerConnection <> nil then begin if FAuthenticationHandler <> nil then FAuthenticationHandler.OnTransportLayerDisconnected; if FProxyAuthenticationHandler <> nil then FProxyAuthenticationHandler.OnTransportLayerDisconnected; FTransportLayerConnection := nil; FUsingTlsLayer := False; //FCreatingProxyTlsTunnel := False; // <- don't set this to false here, keep value of FCreatingProxyTlsTunnel over closed connections! FTargetHost.Clear; FProxyTunnelHost.Clear; end; end; function TGMHttpClientSession.InternalConnectTransportLayer(const ATargetUri, AProxyUri: RGMUriComponents): IGMSocketIO; var socket: IGMSocket; connectUri: RGMUriComponents; useProxy: Boolean; procedure ExecuteTlsConnectRequest; var socket: IGMSocket; begin if (FTransportLayerConnection = nil) or FCreatingProxyTlsTunnel then Exit; FCreatingProxyTlsTunnel := True; // <- prevent recursion of CONNECT request! try GMCheckQueryInterface(FTransportLayerConnection, IGMSocket, socket, {$I %CurrentRoutine%}); ExecuteRequest(nil, ATargetUri.Uri, cHttpMethodCONNECT); FProxyTunnelHost := ATargetUri; FTransportLayerConnection := GMAddTlsLayer(socket, ATargetUri.Host, FCertificateStatusNotifySink, FCertificateData); FUsingTlsLayer := True; finally FCreatingProxyTlsTunnel := False; end; end; begin useProxy := Length(AProxyUri.Host) > 0; if useProxy then connectUri := AProxyUri else connectUri := ATargetUri; //if AndereProxyrHttpTunnel then DisconnectTransportLayer; if Length(connectUri.Scheme) <= 0 then connectUri.Scheme := scStrHttp; if Length(connectUri.Port) <= 0 then {$IFDEF TLS_SUPPORT} if GMSameText(connectUri.Scheme, scStrHttps) then connectUri.Port := scDfltHttpsPort else connectUri.Port := vDfltHttpPort; {$ELSE} connectUri.Port := vDfltHttpPort; {$ENDIF} if (FTransportLayerConnection = nil) or not (GMSameText(FTargetHost.Scheme, connectUri.Scheme) and GMSameText(FTargetHost.Host, connectUri.Host) and GMSameText(FTargetHost.Port, connectUri.Port)) then begin DisconnectTransportLayer; if not GMSameText(connectUri.Scheme, scStrHttp) {$IFDEF TLS_SUPPORT}and not GMSameText(connectUri.Scheme, scStrHttps){$ENDIF} then raise EGMHttpException.ObjError(GMFormat(RStrUnsupportedINetProtocol, [connectUri.Scheme]), Self, {$I %CurrentRoutine%}) else begin socket := TGMTcpSocket.Create(vDfltInetAddrFamily, FAskCanceled); socket.Connect(connectUri.Host, connectUri.Port); //FTransportLayerConnection := socket; {$IFDEF TLS_SUPPORT} if not GMSameText(connectUri.Scheme, scStrHttps) then FTransportLayerConnection := socket else begin //if ACreateTlsProxyTunnel then ExecuteTlsConnectRequest; FTransportLayerConnection := GMAddTlsLayer(socket, ATargetUri.Host, FCertificateStatusNotifySink, FCertificateData); FUsingTlsLayer := True; end; {$ELSE} FTransportLayerConnection := socket; {$ENDIF} end; FTargetHost := connectUri; end; Result := FTransportLayerConnection; {$IFDEF TLS_SUPPORT} if useProxy and GMSameText(ATargetUri.Scheme, scStrHttps) and not (GMSameText(FProxyTunnelHost.Host, ATargetUri.Host) and GMSameText(FProxyTunnelHost.Port, ATargetUri.Port)) then ExecuteTlsConnectRequest; {$ENDIF} end; function TGMHttpClientSession.ConnectTransportLayer(const AUri: TGMString): RConnectTransportLayerResult; var targetUri, proxyUri: RGMUriComponents; begin targetUri := GMParseUri(AUri); Result.UseProxy := UseProxy(AUri); if Result.UseProxy then proxyUri := GMParseUri(FProxyConfig.ProxyHostUri) else proxyUri := Default(RGMUriComponents); Result.TransportLayerConnection := InternalConnectTransportLayer(targetUri, proxyUri); end; procedure TGMHttpClientSession.CreateAuthentificationHandler(const AHeaders: IGMIntfCollection; var ACurrentHandler: IGMHttpClientAuthenticationHandler; const AUseProxy: Boolean; const AUserName, APassword: TGMString); var searchName, unkHeader, unkHandler: IUnknown; getValue: IGMGetStringValue; allHandlerClasses, supportedHandlerClasses: IGMIntfCollection; authSchemeHandlerClass: IGMGetHttpClientAuthSchemeHandlerClass; it: IGMIterator; authScheme, unsupportedAuthSchemes, errMsg: TGMString; // getName: IGMGetName; procedure CreateAuthHandler(const AAuthenticationHandlerClass: TGMHttpClientAuthenticationHandlerClass; const AAuthSchemeName: TGMString); begin // // Better allow changing the authentication handler // // if ACurrentHandler <> nil then // begin // if not GMSameText(AAuthSchemeName, ACurrentHandler.AuthSchemeName) then // raise EGMHttpException.ObjError(GMFormat(RStrHttpAuthSchemeChangeFmt, [ACurrentHandler.AuthSchemeName, AAuthSchemeName]), Self, {$I %CurrentRoutine%}); // end // else if (AAuthenticationHandlerClass <> nil) and ((ACurrentHandler = nil) or (ACurrentHandler.GetClassType <> AAuthenticationHandlerClass)) then ACurrentHandler := AAuthenticationHandlerClass.Create(AUseProxy, AUserName, APassword, True); end; begin if AHeaders = nil then Exit; unsupportedAuthSchemes := ''; allHandlerClasses := RegisterHttpClientAuthHanlderClasses; supportedHandlerClasses := TGMIntfArrayCollection.Create(False, True, GMCompareByPosition); //it := AHeaders.CreateIterator; it := TGMInetHeaderIterator.Create(AHeaders.CreateIterator, cAuthenticateHeaderName[AUseProxy]); while it.NextEntry(unkHeader) do if GMQueryInterface(unkHeader, IGMGetStringValue, getValue) then begin //if not GMQueryInterface(unkHeader, IGMGetName, getName) or // not GMQueryInterface(unkHeader, IGMGetStringValue, getValue) or // not GMSameText(getName.Name, cAuthenticateHeaderName[AUseProxy]) then Continue; authScheme := GMFirstWord(getValue.StringValue, ' '); searchName := TGMNameObj.Create(authScheme); if allHandlerClasses.Find(searchName, unkHandler) then supportedHandlerClasses.Add(unkHandler) else unsupportedAuthSchemes := GMStringJoin(unsupportedAuthSchemes, ', ', '"'+authScheme+'"'); end; if supportedHandlerClasses.IsEmpty then begin if Length(unsupportedAuthSchemes) > 0 then errMsg := GMFormat(srHttpAuthSchmeNotImplFmt, [unsupportedAuthSchemes]) else errMsg := GMFormat(srNoAuthSchemeProvidedByServer, [cAuthenticateHeaderName[AUseProxy]]); raise EGMHttpException.ObjError(errMsg, Self, {$I %CurrentRoutine%}) end else begin GMCheckQueryInterface(supportedHandlerClasses.First, IGMGetHttpClientAuthSchemeHandlerClass, authSchemeHandlerClass, {$I %CurrentRoutine%}); CreateAuthHandler(authSchemeHandlerClass.GetAuthSchemeHandlerClass, GMGetIntfName(authSchemeHandlerClass)); end; end; function TGMHttpClientSession.ExecuteRequest(AHttpRequest: IGMHttpClientRequest; AUri, AHttpMethod: TGMString; const ARequestContent: ISequentialStream; const AAdditionalHeaders: TGMNameAndStrValArray; const AOnUploadProgressProc: TGMOnProgressProc; const AUploadBuffersize: LongInt): RGMRequestResult; var deniedCount, proxyDeniedCount, redirectCount, reconnectCount: Integer; requestContentStartPos: Int64; useProxy: Boolean; uriComponents: RGMUriComponents; tmpUri, username, password, nestedErrMsg: TGMString; procedure Connect(const AUriToConnect: TGMString); var oldConnection: IGMSocketIO; begin oldConnection := FTransportLayerConnection; useProxy := ConnectTransportLayer(AUriToConnect).UseProxy; if oldConnection <> FTransportLayerConnection then Result.ResponseContent := nil; end; procedure ResetRequest; begin GMSetIStreamAbsPos(ARequestContent, requestContentStartPos, {$I %CurrentRoutine%}); GMSetReadContentSize(Result.ResponseContent, cStrmSizeUnlimited); // <- No Limit when reading headers of next response! AHttpRequest.Obj.ReceivedHeaders.Clear; end; procedure Redirect(const ANewUri: TGMString); begin if Length(ANewUri) <= 0 then raise EGMHttpException.ObjError(srNoRedirectionUri, Self, {$I %CurrentRoutine%}); Connect(ANewUri); AUri := ANewUri; end; procedure ReConnectTransportLayer; var connectedUri: TGMString; begin connectedUri := FTargetHost.Uri; DisconnectTransportLayer; //FTargetHost.Clear; // := GMInitUriComponents('', '', '', '', '', '', '', ''); Connect(connectedUri); end; procedure IncrementAndCheckRedirectCount; begin Inc(redirectCount); if redirectCount > vMaxHttpRedirectCount then raise EGMHttpException.ObjError(GMFormat(srTooManyRedirects, [redirectCount]), Self, {$I %CurrentRoutine%}); end; begin useProxy := False; Result.ResponseContent := nil; // <- if not cleared a previous instance may be erroneously re-used due to memory manager misbehave if Length(AHttpMethod) <= 0 then AHttpMethod := cHttpMethodGET; if AHttpRequest = nil then AHttpRequest := TGMHttpClientRequest.Create(scGMHttpAgent); Result.Request := AHttpRequest; requestContentStartPos := GMIStreamPos(ARequestContent); redirectCount := 0; reconnectCount := 0; deniedCount := 0; proxyDeniedCount := 0; repeat try AUri := GMUriEncode(AUri); // <- AURI may be re-assigned by Redirect! uriComponents := GMParseUri(AUri); if not IsTransportLayerConnected then Connect(AUri); if not IsTransportLayerConnected then raise EGMHttpException.ObjError(srTranspoerLayerNotConnected, Self, {$I %CurrentRoutine%}); if Result.ResponseContent = nil then Result.ResponseContent := TGMHttpSocketStream.Create(FTransportLayerConnection); ResetRequest; GMAddINetHeader(AHttpRequest.Obj.HeadersToSend, 'Host', GMHttpHostHeader(uriComponents)); if FAuthenticationHandler <> nil then FAuthenticationHandler.AddAuthorizationHeader(AHttpRequest.Obj.HeadersToSend); // Don't add a proxy authentication header after we created a proxy tunnel if (FProxyAuthenticationHandler <> nil) and (Length(FProxyTunnelHost.Host) <= 0) then FProxyAuthenticationHandler.AddAuthorizationHeader(AHttpRequest.Obj.HeadersToSend); //if useProxy then // begin if FProxyAuthenticationHandler <> nil then FProxyAuthenticationHandler.AddAuthorizationHeader(AHttpRequest.Obj.HeadersToSend); end //else // if FAuthenticationHandler <> nil then FAuthenticationHandler.AddAuthorizationHeader(AHttpRequest.Obj.HeadersToSend); //if FProxyConfig <> nil then username := FProxyConfig.Username else username := ''; //if FProxyConfig <> nil then password := FProxyConfig.Password else password := ''; try Result := AHttpRequest.Obj.InternalExecute(Result.ResponseContent, useProxy, AHttpMethod, uriComponents, ARequestContent, AAdditionalHeaders, AOnUploadProgressProc, AUploadBuffersize, FUsingTlsLayer); finally if GMSameText(GMGetINetHeaderStrValue(AHttpRequest.Obj.ReceivedHeaders, cHttpConnection), cHttpClose) then DisconnectTransportLayer; // <- the Result stream may still hold a reference to the socket connection and may use it until it is released end; Break; // <- Always leave repeat loop if no exception occured except on ex: TObject do case GMExtractHttpCodeFromHResult(GMGetObjHrCode(ex)) of HTTP_STATUS_DENIED: begin Inc(deniedCount); nestedErrMsg := ''; try CreateAuthentificationHandler(AHttpRequest.Obj.ReceivedHeaders, FAuthenticationHandler, False, FUserName, FPassword); except on innerEx: TObject do nestedErrMsg := GMMsgFromExceptObj(innerEx); end; if Length(nestedErrMsg) > 0 then begin GMExtendExceptionMsg(ex, nestedErrMsg, c2NewLine); raise; end; if FAuthenticationHandler = nil then raise; if not FAuthenticationHandler.ProcessAuthDenied(AHttpRequest.Obj.ReceivedHeaders, deniedCount, FAskLoginData) then raise; //ResetRequest; end; HTTP_STATUS_PROXY_AUTH_REQ: begin Inc(proxyDeniedCount); nestedErrMsg := ''; if FProxyConfig <> nil then username := FProxyConfig.Username else username := ''; if FProxyConfig <> nil then password := FProxyConfig.Password else password := ''; try CreateAuthentificationHandler(AHttpRequest.Obj.ReceivedHeaders, FProxyAuthenticationHandler, True, username, password); except on innerEx: TObject do nestedErrMsg := GMMsgFromExceptObj(innerEx); end; if Length(nestedErrMsg) > 0 then begin GMExtendExceptionMsg(ex, nestedErrMsg, c2NewLine); raise; end; if FProxyAuthenticationHandler = nil then raise; if not FProxyAuthenticationHandler.ProcessAuthDenied(AHttpRequest.Obj.ReceivedHeaders, proxyDeniedCount, FAskLoginData) then raise; //ResetRequest; end; HTTP_STATUS_MOVED, HTTP_STATUS_REDIRECT, HTTP_STATUS_REDIRECT_KEEP_VERB: begin IncrementAndCheckRedirectCount; Redirect(GMGetINetHeaderStrValue(AHttpRequest.Obj.ReceivedHeaders, cStrHttpLocation, '', True)); //ResetRequest; end; HTTP_STATUS_USE_PROXY: begin IncrementAndCheckRedirectCount; tmpUri := GMGetINetHeaderStrValue(AHttpRequest.Obj.ReceivedHeaders, cStrHttpLocation, '', True); if FProxyConfig = nil then FProxyConfig := TGMHttpProxyConfig.Create(tmpUri) else begin FProxyConfig.ProxyHostUri := tmpUri; FProxyConfig.ProxyBypass := ''; end; //ResetRequest; ReConnectTransportLayer; end; else if not GMIsSocketReConnectErrorCode(GMGetObjHRCode(exceptObject)) then raise else begin Inc(reconnectCount); if reconnectCount > vMaxHttpReConnectCount then raise EGMHttpException.ObjError(GMFormat(srTooManyReconnects, [reconnectCount]), Self, {$I %CurrentRoutine%}); ReConnectTransportLayer; //ResetRequest; end; end; end; until False; end; { ------------------------------ } { ---- TGMHttpServerRequest ---- } { ------------------------------ } function TGMHttpServerRequest.Obj: TGMHttpServerRequest; begin Result := Self; end; procedure TGMHttpServerRequest.AddMinimalResponseHeaders(const AHeaders: IGMIntfCollection); begin GMAddINetHeader(HeadersToSend, 'Server', 'GMServer/1.0', hamAddIfNew); GMAddINetHeader(HeadersToSend, cHttpContentLength, '0', hamAddIfNew); GMAddINetHeader(HeadersToSend, 'Date', GMEncodeUtcToINetTime(GMLocalTimeToUTC(Now, nil, Self), Self), hamAddIfNew); end; procedure TGMHttpServerRequest.ProcessRequest(const ATransportLayer: ISequentialStream; const ARequestProcessor: IUnknown); var processor: IGMProcessServerRequest; httpRetCode: LongInt; resultHdrs: AnsiString; method, url, httpVersion: TGMString; begin GMParseHttpStartLine(ReceiveHeaders(ATransportLayer, ReceivedHeaders), method, url, httpVersion); if not GMQueryInterface(ARequestProcessor, IGMProcessServerRequest, processor) then httpRetCode := HTTP_STATUS_SERVER_ERROR else try httpRetCode := processor.ProcessRequest(Self, method, GMUriDecode(url)); except GMTraceException(ExceptObject); httpRetCode := HTTP_STATUS_SERVER_ERROR; end; AddMinimalResponseHeaders(HeadersToSend); resultHdrs := httpVersion + ' ' + IntToStr(httpRetCode) + ' ' + GMHttpShortHint(httpRetCode); resultHdrs := GMStringJoin(resultHdrs, CRLF, GMHeadersAsString(HeadersToSend)) + CRLF + CRLF; vfGMTrace(resultHdrs, ProtocolDisplayName); GMSafeIStreamWrite(ATransportLayer, PAnsiChar(resultHdrs), Length(resultHdrs), 'Sending HTTP response headers'); processor.SendResponseContents(ATransportLayer); end; { -------------------------------- } { ---- TGMHttpContentInfoImpl ---- } { -------------------------------- } function TGMHttpContentInfoImpl.ContentEncoding: TGMString; begin Result := FContentEncoding; end; function TGMHttpContentInfoImpl.ContentType: TGMString; begin Result := FContentType; end; procedure TGMHttpContentInfoImpl.SetContentEncoding(const AContentEncoding: TGMString); begin FContentEncoding := AContentEncoding; end; procedure TGMHttpContentInfoImpl.SetContentType(const AContentType: TGMString); begin FContentType := AContentType; end; { ----------------------------- } { ---- TGMHttpSocketStream ---- } { ----------------------------- } constructor TGMHttpSocketStream.Create(const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FHttpContentInfo := TGMHttpContentInfoImpl.Create(True); end; { --------------------------------------- } { ---- TGMHttpZipDecompressorIStream ---- } { --------------------------------------- } {$IFDEF HTTP_ZIP_SUPPORT} constructor TGMHttpZipDecompressorIStream.Create(const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FHttpContentInfo := TGMHttpContentInfoImpl.Create(True); end; {$ENDIF} { ------------------------------ } { ---- TGMHttpChunkedStream ---- } { ------------------------------ } constructor TGMHttpChunkedStream.Create(const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FHttpContentInfo := TGMHttpContentInfoImpl.Create(True); FChunkReadPos := 1; end; constructor TGMHttpChunkedStream.CreateRead(const AProtocolObj: IGMINetProtocolBase; const AChainedStream: ISequentialStream; const AMode: DWORD; const AName: UnicodeString; const ARefLifeTime: Boolean); begin inherited Create(AMode, AName, ARefLifeTime); FChainedStream := AChainedStream; FProtocolObj := AProtocolObj; GMCheckPointerAssigned(Pointer(FProtocolObj), srTheProtocolObj, Self); end; procedure TGMHttpChunkedStream.ReadChunk; // : Boolean; var line, term: AnsiString; chPos: PtrInt; chunkSize: Int64; begin if FEOS then Exit; line := FProtocolObj.Obj.ReadResponseLine(FChainedStream); chPos := 1; chunkSize := GMStrToInt64('$'+GMStrip(GMNextWord(chPos, line, ';'))); //chunkSize := GMStrToInt(GMMakeDezInt(GMFirstWord(line, ';'))); SetLength(FChunkData, chunkSize); if chunkSize > 0 then begin GMSafeIStreamRead(FChainedStream, PAnsiChar(FChunkData), chunkSize, {$I %CurrentRoutine%}); SetLength(term, 2); GMSafeIStreamRead(FChainedStream, PAnsiChar(term), Length(term), {$I %CurrentRoutine%}); if term <> CRLF then raise EGMHttpException.ObjError(srInvalidHttpChunkTerm+': '+term); end else begin FProtocolObj.Obj.ReceiveHeaders(FChainedStream, nil); // <- dont add headers that are not allowed as trailers (content-Length, Transfer-Encoding, Trailers) FEOS := True; end; FChunkReadPos := 1; //Result := chunkSize > 0; end; procedure TGMHttpChunkedStream.InternalRead(pv: Pointer; cb: LongWord; var pcbRead: LongWord); begin if (FChunkReadPos > Length(FChunkData)) and not FEOS then ReadChunk; if FChunkReadPos > Length(FChunkData) then pcbRead := 0 else begin pcbRead := Max(0, Min(cb, Length(FChunkData) - FChunkReadPos + 1)); if pcbRead > 0 then Move(FChunkData[FChunkReadPos], pv^, pcbRead); Inc(FChunkReadPos, pcbRead); //FChunkReadPos += pcbRead; end; end; procedure TGMHttpChunkedStream.InternalWrite(pv: Pointer; cb: LongWord; var pcbWritten: LongWord); begin if FChainedStream <> nil then GMHrCheckObj(FChainedStream.Write(pv, cb, PLongInt(@pcbWritten)), Self, 'InternalWrite') else pcbWritten := 0; end; { ----------------------------------- } { ---- routines from winHttp.DLL ---- } { ----------------------------------- } //function WinHttpGetIEProxyConfigForCurrentUser(pProxyConfig: PWinHttpCurrentUserIEProxyConfig): BOOL; stdcall; const cWinHttpDll = 'WinHttp.DLL'; {$IFDEF DELAY_LOAD_WIN_DLLs} var vf_WinHttpGetIEProxyConfigForCurrentUser: function (pProxyConfig: PWinHttpCurrentUserIEProxyConfig): BOOL; stdcall = nil; function WinHttpGetIEProxyConfigForCurrentUser; begin if not Assigned(vf_WinHttpGetIEProxyConfigForCurrentUser) then vf_WinHttpGetIEProxyConfigForCurrentUser := GMGetProcAddress(cwinHttpDll, 'WinHttpGetIEProxyConfigForCurrentUser'); Result := vf_WinHttpGetIEProxyConfigForCurrentUser(pProxyConfig); end; {$ELSE} function WinHttpGetIEProxyConfigForCurrentUser; external cwinHttpDll; {$ENDIF DELAY_LOAD_WIN_DLLs} initialization // Create Critical Section in main thread when loaded vCSRegisterHttpClientAuthHanlderClasses := TGMCriticalSection.Create; vCSRegisterHttpTransferDecoders := TGMCriticalSection.Create; end.