{******************************************************************************} { } { Library: Fundamentals 5.00 } { File name: flcHTTPUtils.pas } { File version: 5.12 } { Description: HTTP utilities. } { } { Copyright: Copyright (c) 2011-2020, David J Butler } { All rights reserved. } { This file is licensed under the BSD License. } { See http://www.opensource.org/licenses/bsd-license.php } { Redistribution and use in source and binary forms, with } { or without modification, are permitted provided that } { the following conditions are met: } { Redistributions of source code must retain the above } { copyright notice, this list of conditions and the } { following disclaimer. } { THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND } { CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED } { WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED } { WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A } { PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL } { THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, } { INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR } { CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, } { PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF } { USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) } { HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER } { IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING } { NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE } { USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE } { POSSIBILITY OF SUCH DAMAGE. } { } { Github: https://github.com/fundamentalslib } { E-mail: fundamentals.library at gmail.com } { } { Revision history: } { } { 2011/06/05 0.01 Initial development on HTTP parser } { 2011/06/11 0.02 Further development. Simple test cases. } { 2011/06/12 0.03 Structure to string functions. } { 2011/06/13 0.04 Content decoder class. } { 2011/06/16 0.05 Chunked encoding decoder. } { 2011/06/17 0.06 Cookie/Set-Cookie fields. } { 2011/06/25 0.07 Content reader/writer classes. } { 2011/07/31 0.08 Improved logging. } { 2015/02/28 0.09 Decode url-encoded content. } { 2015/03/14 0.10 RawByteString changes. } { 2016/01/09 5.11 Revised for Fundamentals 5. } { 2019/07/29 5.12 SendContent fix. } { } { References: } { } { * HTTP/1.1 : http://www.w3.org/Protocols/rfc2616/rfc2616.html } { * Chunked encoding : http://tools.ietf.org/html/rfc2616#section-3.6.1 } { * Origin header : https://wiki.mozilla.org/Security/Origin } { * http://homepage.ntlworld.com./jonathan.deboynepollard/FGA/web-proxy-connection-header.html } { * http://www.w3.org/TR/html4/interact/forms.html } { } {******************************************************************************} {$INCLUDE flcHTTP.inc} unit flcHTTPUtils; interface uses { System } SysUtils, Classes, { Fundamentals } flcStdTypes, flcUtils, flcStrings, flcStringBuilder, flcTCPBuffer; type { Errors } EHTTP = class(Exception); EHTTPParser = class(EHTTP); { Version } THTTPProtocolEnum = ( hpNone, hpCustom, hpHTTP, hpHTTPS); THTTPVersionEnum = ( hvNone, hvCustom, hvHTTP10, hvHTTP11); THTTPVersion = record Version : THTTPVersionEnum; Protocol : THTTPProtocolEnum; CustomProtocol : RawByteString; CustomMajVersion : Integer; CustomMinVersion : Integer; end; { Header name } THTTPHeaderNameEnum = ( hntCustom, hntHost, hntContentType, hntContentLength, hntContentTransferEncoding, hntContentLocation, hntContentLanguage, hntContentEncoding, hntTransferEncoding, hntDate, hntServer, hntUserAgent, hntLocation, hntConnection, hntExpires, hntCacheControl, hntSetCookie, hntCookie, hntAuthorization, hntVia, hntWarning, hntContentRange, hntXForwardedFor, hntPragma, hntXPoweredBy, hntWWWAuthenticate, hntLastModified, hntETag, hntProxyAuthorization, hntReferer, hntAge, hntAcceptRanges, hntAcceptEncoding, hntAcceptLanguage, hntAcceptCharset, hntIfModifiedSince, hntIfUnmodifiedSince, hntRetryAfter, hntUpgrade, hntStatus, hntProxyConnection, hntOrigin, hntKeepAlive); THTTPHeaderName = record Value : THTTPHeaderNameEnum; Custom : RawByteString; end; { Header } THTTPCustomHeader = record FieldName : RawByteString; FieldValue : RawByteString; end; PHTTPCustomHeader = ^THTTPCustomHeader; { Content Length } THTTPContentLengthEnum = ( hcltNone, hcltByteCount); THTTPContentLength = record Value : THTTPContentLengthEnum; ByteCount : Int64; end; PHTTPContentLength = ^THTTPContentLength; { Content Type } THTTPContentTypeMajor = ( hctmCustom, hctmText, hctmImage); THTTPContentTypeEnum = ( hctNone, hctCustomParts, hctCustomString, hctTextHtml, hctTextAscii, hctTextCss, hctTextPlain, hctTextXml, hctTextCustom, hctImageJpeg, hctImagePng, hctImageGif, hctImageIcon, hctImageCustom, hctApplicationJSON, hctApplicationOctetStream, hctApplicationJavaScript, hctApplicationCustom, hctAudioCustom, hctVideoCustom); THTTPContentType = record Value : THTTPContentTypeEnum; CustomMajor : RawByteString; CustomMinor : RawByteString; Parameters : RawByteStringArray; CustomStr : RawByteString; end; { Date } THTTPDateFieldEnum = ( hdNone, hdCustom, hdParts, hdDateTime); THTTPDateField = record Value : THTTPDateFieldEnum; DayOfWeek : Integer; Day, Month, Year : Integer; Hour, Min, Sec : Integer; TimeZoneGMT : Boolean; CustomTimeZone : RawByteString; DateTime : TDateTime; Custom : RawByteString; end; { Transfer-Encoding } THTTPTransferEncodingEnum = ( hteNone, hteCustom, hteChunked); THTTPTransferEncoding = record Value : THTTPTransferEncodingEnum; Custom : RawByteString; end; { Connection } THTTPConnectionFieldEnum = ( hcfNone, hcfCustom, hcfClose, hcfKeepAlive); THTTPConnectionField = record Value : THTTPConnectionFieldEnum; Custom : RawByteString; end; { Age } THTTPAgeFieldEnum = ( hafNone, hafCustom, hafAge); THTTPAgeField = record Value : THTTPAgeFieldEnum; Age : Int64; Custom : RawByteString; end; { Cache Control *** } THTTPCacheControlFieldEnum = ( hccfNone, hccfDecoded, hccfCustom); THTTPCacheControlRequestSubField = ( hccsfNoCache, hccsfNoStore, hccsfMaxAge, hccsfMaxStale, hccsfMinFresh, hccsfNoTransform, hccsfOnlyIfCached); THTTPCacheControlResponseSubField = ( hccrfPublic, hccrfPrivate, hccrfNoCache, hccrfNoStore, hccrfNoTransform, hccrfMustRevalidate, hccrfProxyRevalidate, hccrfMaxAge, hccrfSMaxAge); THTTPCacheControlField = record Value : THTTPCacheControlFieldEnum; end; { Content-Encoding } THTTPContentEncodingEnum = ( hceNone, hceCustom, hceIdentity, hceCompress, hceDeflate, hceExi, hceGzip, hcePack200Gzip); THTTPContentEncoding = record Value : THTTPContentEncodingEnum; Custom : RawByteString; end; THTTPContentEncodingFieldEnum = ( hcefNone, hcefList); THTTPContentEncodingField = record Value : THTTPContentEncodingFieldEnum; List : array of THTTPContentEncoding; end; { Retry After *** } THTTPRetryAfterFieldEnum = ( hrafNone, hrafCustom, harfDate, harfSeconds); THTTPRetryAfterField = record Value : THTTPRetryAfterFieldEnum; Custom : RawByteString; Date : TDateTime; Seconds : Int64; end; { Content-Range *** } THTTPContentRangeFieldEnum = ( hcrfNone, hcrfCustom, hcrfByteRange); THTTPContentRangeField = record Value : THTTPContentRangeFieldEnum; ByteFirst : Int64; ByteLast : Int64; ByteSize : Int64; Custom : RawByteString; end; { Set Cookie } THTTPSetCookieFieldEnum = ( hscoNone, hscoDecoded, hscoCustom); THTTPSetCookieCustomField = record Name : RawByteString; Value : RawByteString; end; PHTTPSetCookieCustomField = ^THTTPSetCookieCustomField; THTTPSetCookieCustomFieldArray = array of THTTPSetCookieCustomField; THTTPSetCookieField = record Value : THTTPSetCookieFieldEnum; Domain : RawByteString; Path : RawByteString; Expires : THTTPDateField; MaxAge : Int64; HttpOnly : Boolean; Secure : Boolean; CustomFields : THTTPSetCookieCustomFieldArray; Custom : RawByteString; end; PHTTPSetCookieField = ^THTTPSetCookieField; THTTPSetCookieFieldArray = array of THTTPSetCookieField; { Cookie } THTTPCookieFieldEnum = ( hcoNone, hcoDecoded, hcoCustom); THTTPCookieFieldEntry = record Name : RawByteString; HasValue : Boolean; Value : RawByteString; end; PHTTPCookieFieldEntry = ^THTTPCookieFieldEntry; THTTPCookieFieldEntryArray = array of THTTPCookieFieldEntry; THTTPCookieField = record Value : THTTPCookieFieldEnum; Entries : THTTPCookieFieldEntryArray; Custom : RawByteString; end; { Common headers } THTTPCommonHeaders = record TransferEncoding : THTTPTransferEncoding; ContentType : THTTPContentType; ContentLength : THTTPContentLength; Connection : THTTPConnectionField; ProxyConnection : THTTPConnectionField; Date : THTTPDateField; ContentEncoding : THTTPContentEncodingField; end; { Fixed headers } THTTPFixedHeaders = array[THTTPHeaderNameEnum] of RawByteString; { Custom headers } THTTPCustomHeaders = array of THTTPCustomHeader; { Method } THTTPMethodEnum = ( hmNone, hmCustom, hmGET, hmPUT, hmPOST, hmCONNECT, hmHEAD, hmDELETE, hmOPTIONS, hmTRACE); THTTPMethod = record Value : THTTPMethodEnum; Custom : RawByteString; end; { Request } THTTPRequestStartLine = record Method : THTTPMethod; URI : RawByteString; Version : THTTPVersion; end; THTTPRequestHeader = record CommonHeaders : THTTPCommonHeaders; FixedHeaders : THTTPFixedHeaders; CustomHeaders : THTTPCustomHeaders; Cookie : THTTPCookieField; IfModifiedSince : THTTPDateField; IfUnmodifiedSince : THTTPDateField; end; PHTTPRequestHeader = ^THTTPRequestHeader; THTTPRequest = record StartLine : THTTPRequestStartLine; Header : THTTPRequestHeader; HeaderComplete : Boolean; HasContent : Boolean; end; PHTTPRequest = ^THTTPRequest; { Response } THTTPResponseStartLineMessage = ( hslmNone, hslmCustom, hslmContinue, hslmSwitchingProtocols, hslmOK, hslmCreated, hslmAccepted, hslmNonAuthoritativeInformation, hslmNoContent, hslmResetContent, hslmPartialContent, hslmMultipleChoices, hslmMovedPermanently, hslmFound, hslmSeeOther, hslmNotModified, hslmUseProxy, hslmTemporaryRedirect, hslmBadRequest, hslmUnauthorized, hslmPaymentRequired, hslmForbidden, hslmNotFound, hslmMethodNotAllowed, hslmNotAcceptable, hslmProxyAuthenticationRequired, hslmRequestTimeout, hslmConflict, hslmGone, hslmLengthRequired, hslmPreconditionFailed, hslmRequestEntityTooLarge, hslmRequestURITooLong, hslmUnsupportedMediaType, hslmRequestedRangeNotSatisfiable, hslmExpectationFailed, hslmInternalServerError, hslmNotImplemented, hslmBadGateway, hslmServiceUnavailable, hslmGatewayTimeout, hslmHTTPVersionNotSupported); THTTPResponseStartLine = record Version : THTTPVersion; Code : Integer; Msg : THTTPResponseStartLineMessage; CustomMsg : RawByteString; end; THTTPResponseHeader = record CommonHeaders : THTTPCommonHeaders; FixedHeaders : THTTPFixedHeaders; CustomHeaders : THTTPCustomHeaders; SetCookies : THTTPSetCookieFieldArray; Expires : THTTPDateField; LastModified : THTTPDateField; Age : THTTPAgeField; end; PHTTPResponseHeader = ^THTTPResponseHeader; THTTPResponse = record StartLine : THTTPResponseStartLine; Header : THTTPResponseHeader; HeaderComplete : Boolean; HasContent : Boolean; end; PHTTPResponse = ^THTTPResponse; { Response codes } const HTTP_ResponseCode_Continue = 100; HTTP_ResponseCode_SwitchingProtocols = 101; HTTP_ResponseCode_OK = 200; HTTP_ResponseCode_Created = 201; HTTP_ResponseCode_Accepted = 202; HTTP_ResponseCode_NonAuthoritativeInformation = 203; HTTP_ResponseCode_NoContent = 204; HTTP_ResponseCode_ResetContent = 205; HTTP_ResponseCode_PartialContent = 206; HTTP_ResponseCode_MultipleChoices = 300; HTTP_ResponseCode_MovedPermanently = 301; HTTP_ResponseCode_Found = 302; HTTP_ResponseCode_SeeOther = 303; HTTP_ResponseCode_NotModified = 304; HTTP_ResponseCode_UseProxy = 305; HTTP_ResponseCode_TemporaryRedirect = 307; HTTP_ResponseCode_BadRequest = 400; HTTP_ResponseCode_Unauthorized = 401; HTTP_ResponseCode_PaymentRequired = 402; HTTP_ResponseCode_Forbidden = 403; HTTP_ResponseCode_NotFound = 404; HTTP_ResponseCode_MethodNotAllowed = 405; HTTP_ResponseCode_NotAcceptable = 406; HTTP_ResponseCode_ProxyAuthenticationRequired = 407; HTTP_ResponseCode_RequestTimeout = 408; HTTP_ResponseCode_Conflict = 409; HTTP_ResponseCode_Gone = 410; HTTP_ResponseCode_LengthRequired = 411; HTTP_ResponseCode_PreconditionFailed = 412; HTTP_ResponseCode_RequestEntityTooLarge = 413; HTTP_ResponseCode_RequestURITooLong = 414; HTTP_ResponseCode_UnsupportedMediaType = 415; HTTP_ResponseCode_RequestedRangeNotSatisfiable = 416; HTTP_ResponseCode_ExpectationFailed = 417; HTTP_ResponseCode_InternalServerError = 500; HTTP_ResponseCode_NotImplemented = 501; HTTP_ResponseCode_BadGateway = 502; HTTP_ResponseCode_ServiceUnavailable = 503; HTTP_ResponseCode_GatewayTimeout = 504; HTTP_ResponseCode_HTTPVersionNotSupported = 505; function HTTPResponseCodeToStartLineMessage(const ResponseCode: Integer): THTTPResponseStartLineMessage; { Structure helpers } function HTTPMessageHasContent(const H: THTTPCommonHeaders): Boolean; procedure InitHTTPRequest(var A: THTTPRequest); procedure InitHTTPResponse(var A: THTTPResponse); procedure ClearHTTPVersion(var A: THTTPVersion); procedure ClearHTTPContentLength(var A: THTTPContentLength); procedure ClearHTTPContentType(var A: THTTPContentType); procedure ClearHTTPDateField(var A: THTTPDateField); procedure ClearHTTPTransferEncoding(var A: THTTPTransferEncoding); procedure ClearHTTPConnectionField(var A: THTTPConnectionField); procedure ClearHTTPAgeField(var A: THTTPAgeField); procedure ClearHTTPContentEncoding(var A: THTTPContentEncoding); procedure ClearHTTPContentEncodingField(var A: THTTPContentEncodingField); procedure ClearHTTPContentRangeField(var A: THTTPContentRangeField); procedure ClearHTTPSetCookieField(var A: THTTPSetCookieField); procedure ClearHTTPCommonHeaders(var A: THTTPCommonHeaders); procedure ClearHTTPFixedHeaders(var A: THTTPFixedHeaders); procedure ClearHTTPCustomHeaders(var A: THTTPCustomHeaders); procedure ClearHTTPCookieField(var A: THTTPCookieField); procedure ClearHTTPMethod(var A: THTTPMethod); procedure ClearHTTPRequestStartLine(var A: THTTPRequestStartLine); procedure ClearHTTPRequestHeader(var A: THTTPRequestHeader); procedure ClearHTTPRequest(var A: THTTPRequest); procedure ClearHTTPResponseStartLine(var A: THTTPResponseStartLine); procedure ClearHTTPResponseHeader(var A: THTTPResponseHeader); procedure ClearHTTPResponse(var A: THTTPResponse); type THTTPStringOption = (hsoNone); THTTPStringOptions = set of THTTPStringOption; procedure BuildStrHTTPVersion(const A: THTTPVersion; const B: TRawByteStringBuilder; const P: THTTPStringOptions); procedure BuildStrHTTPContentLengthValue(const A: THTTPContentLength; const B: TRawByteStringBuilder; const P: THTTPStringOptions); procedure BuildStrHTTPContentLength(const A: THTTPContentLength; const B: TRawByteStringBuilder; const P: THTTPStringOptions); procedure BuildStrHTTPContentTypeValue(const A: THTTPContentType; const B: TRawByteStringBuilder; const P: THTTPStringOptions); procedure BuildStrHTTPContentType(const A: THTTPContentType; const B: TRawByteStringBuilder; const P: THTTPStringOptions); procedure BuildStrRFCDateTime( const DOW, Da, Mo, Ye, Ho, Mi, Se: Integer; const TZ: RawByteString; const B: TRawByteStringBuilder; const P: THTTPStringOptions); procedure BuildStrHTTPDateFieldValue(const A: THTTPDateField; const B: TRawByteStringBuilder; const P: THTTPStringOptions); procedure BuildStrHTTPDateField(const A: THTTPDateField; const B: TRawByteStringBuilder; const P: THTTPStringOptions); procedure BuildStrHTTPTransferEncodingValue(const A: THTTPTransferEncoding; const B: TRawByteStringBuilder; const P: THTTPStringOptions); procedure BuildStrHTTPTransferEncoding(const A: THTTPTransferEncoding; const B: TRawByteStringBuilder; const P: THTTPStringOptions); procedure BuildStrHTTPContentRangeField(const A: THTTPContentRangeField; const B: TRawByteStringBuilder; const P: THTTPStringOptions); procedure BuildStrHTTPConnectionFieldValue(const A: THTTPConnectionField; const B: TRawByteStringBuilder; const P: THTTPStringOptions); procedure BuildStrHTTPConnectionField(const A: THTTPConnectionField; const B: TRawByteStringBuilder; const P: THTTPStringOptions); procedure BuildStrHTTPAgeField(const A: THTTPAgeField; const B: TRawByteStringBuilder; const P: THTTPStringOptions); procedure BuildStrHTTPContentEncoding(const A: THTTPContentEncoding; const B: TRawByteStringBuilder; const P: THTTPStringOptions); procedure BuildStrHTTPContentEncodingField(const A: THTTPContentEncodingField; const B: TRawByteStringBuilder; const P: THTTPStringOptions); procedure BuildStrHTTPProxyConnectionField(const A: THTTPConnectionField; const B: TRawByteStringBuilder; const P: THTTPStringOptions); procedure BuildStrHTTPCommonHeaders(const A: THTTPCommonHeaders; const B: TRawByteStringBuilder; const P: THTTPStringOptions); procedure BuildStrHTTPFixedHeaders(const A: THTTPFixedHeaders; const B: TRawByteStringBuilder; const P: THTTPStringOptions); procedure BuildStrHTTPCustomHeaders(const A: THTTPCustomHeaders; const B: TRawByteStringBuilder; const P: THTTPStringOptions); procedure BuildStrHTTPSetCookieFieldValue(const A: THTTPSetCookieField; const B: TRawByteStringBuilder; const P: THTTPStringOptions); procedure BuildStrHTTPCookieFieldValue(const A: THTTPCookieField; const B: TRawByteStringBuilder; const P: THTTPStringOptions); procedure BuildStrHTTPCookieField(const A: THTTPCookieField; const B: TRawByteStringBuilder; const P: THTTPStringOptions); procedure BuildStrHTTPMethod(const A: THTTPMethod; const B: TRawByteStringBuilder; const P: THTTPStringOptions); procedure BuildStrHTTPRequestStartLine(const A: THTTPRequestStartLine; const B: TRawByteStringBuilder; const P: THTTPStringOptions); procedure BuildStrHTTPRequestHeader(const A: THTTPRequestHeader; const B: TRawByteStringBuilder; const P: THTTPStringOptions); procedure BuildStrHTTPRequest(const A: THTTPRequest; const B: TRawByteStringBuilder; const P: THTTPStringOptions); procedure BuildStrHTTPResponseCookieFieldArray(const A: THTTPSetCookieFieldArray; const B: TRawByteStringBuilder; const P: THTTPStringOptions); procedure BuildStrHTTPResponseStartLine(const A: THTTPResponseStartLine; const B: TRawByteStringBuilder; const P: THTTPStringOptions); procedure BuildStrHTTPResponseHeader(const A: THTTPResponseHeader; const B: TRawByteStringBuilder; const P: THTTPStringOptions); procedure BuildStrHTTPResponse(const A: THTTPResponse; const B: TRawByteStringBuilder; const P: THTTPStringOptions); function HTTPContentTypeValueToStr(const A: THTTPContentType): RawByteString; function HTTPSetCookieFieldValueToStr(const A: THTTPSetCookieField): RawByteString; function HTTPCookieFieldValueToStr(const A: THTTPCookieField): RawByteString; function HTTPMethodToStr(const A: THTTPMethod): RawByteString; function HTTPRequestToStr(const A: THTTPRequest): RawByteString; function HTTPResponseToStr(const A: THTTPResponse): RawByteString; { Cookies } function GetHTTPCookieFieldEntryIndexByName(const A: THTTPCookieFieldEntryArray; const Name: RawByteString): Integer; function GetHTTPCookieFieldEntryValueByName(const A: THTTPCookieFieldEntryArray; const Name: RawByteString; const Default: RawByteString = ''): RawByteString; procedure PrepareCookie(var A: THTTPCookieField; const B: THTTPSetCookieFieldArray; const Domain: RawByteString; const Secure: Boolean); procedure HTTPSetCookieFieldInitDecoded(var A: THTTPSetCookieField; Path, Domain: RawByteString); procedure HTTPSetCookieFieldAddCustomField(var A: THTTPSetCookieField; const Name, Value : RawByteString); { Custom headers } function HTTPCustomHeadersAdd(var A: THTTPCustomHeaders): PHTTPCustomHeader; overload; function HTTPCustomHeadersAdd(var A: THTTPCustomHeaders; const FieldName: RawByteString): PHTTPCustomHeader; overload; function HTTPCustomHeadersAdd(var A: THTTPCustomHeaders; const FieldName, FieldValue: RawByteString): PHTTPCustomHeader; overload; function HTTPCustomHeadersGetByName(const A: THTTPCustomHeaders; const FieldName: RawByteString): PHTTPCustomHeader; { Url encoded field } type THTTPUrlEncodedField = record Name : RawByteString; Value : RawByteString; end; PHTTPUrlEncodedField = ^THTTPUrlEncodedField; THTTPUrlEncodedFieldArray = array of THTTPUrlEncodedField; function HTTPUrlEncodedUnescapeStr(const S: RawByteString): RawByteString; procedure HTTPUrlEncodedDecode(const S: RawByteString; out Fields: THTTPUrlEncodedFieldArray); function HTTPUrlEncodedFieldsGetFieldPtrByName(const Fields: THTTPUrlEncodedFieldArray; const Name: RawByteString): PHTTPUrlEncodedField; function HTTPUrlEncodedFieldsGetStrByName(const Fields: THTTPUrlEncodedFieldArray; const Name: RawByteString; const Default: RawByteString = ''): RawByteString; function HTTPUrlEncodedFieldsGetIntByName(const Fields: THTTPUrlEncodedFieldArray; const Name: RawByteString; const Default: Int64 = 0): Int64; { Content type } function HTTPWellKnownFileExtenstionToContentType(const Extension: RawByteString): THTTPContentTypeEnum; { THTTPParser } type THTTPParserHeaderParseFunc = function (const HeaderName: THTTPHeaderNameEnum; const HeaderPtr: Pointer): Boolean of object; THTTPParser = class private FBufPtr : Pointer; FBufSize : Integer; FBufPos : Integer; FBufStrRef : RawByteString; function EOF: Boolean; function MatchCh(const C: ByteCharSet): Boolean; function MatchStrAndCh(const S: RawByteString; const CaseSensitive: Boolean; const C: ByteCharSet): Boolean; function MatchStr(const S: RawByteString; const CaseSensitive: Boolean): Boolean; function SkipStrAndCh(const S: RawByteString; const DelimSet: ByteCharSet; const SkipDelim: Boolean; const CaseSensitive: Boolean): Boolean; function SkipCh(const C: ByteCharSet): Boolean; function SkipAllCh(const C: ByteCharSet): Boolean; function SkipToStr(const S: RawByteString; const CaseSensitive: Boolean): Boolean; function SkipCRLF: Boolean; function SkipSpace: Boolean; function SkipLWS: Boolean; function SkipToCRLF: Boolean; function ExtractAllCh(const C: ByteCharSet): RawByteString; function ExtractTo(const C: ByteCharSet; var S: RawByteString; const SkipDelim: Boolean): AnsiChar; function ExtractStrTo(const C: ByteCharSet; const SkipDelim: Boolean): RawByteString; function ExtractInt(const Default: Int64): Int64; function ExtractIntTo(const C: ByteCharSet; const SkipDelim: Boolean; const Default: Int64): Int64; procedure ParseCustomVersion(var Protocol: THTTPVersion); procedure ParseVersion(var Version: THTTPVersion); procedure ParseHeaderName(var HeaderName: THTTPHeaderName); procedure ParseHeaderValue(var HeaderValue: RawByteString); procedure ParseTransferEncoding(var Value: THTTPTransferEncoding); procedure ParseContentType(var Value: THTTPContentType); procedure ParseContentLength(var Value: THTTPContentLength); procedure ParseConnectionField(var Value: THTTPConnectionField); procedure ParseDateField(var Value: THTTPDateField); procedure ParseAgeField(var Value: THTTPAgeField); procedure ParseContentEncoding(var Value: THTTPContentEncoding); procedure ParseContentEncodingField(var Value: THTTPContentEncodingField); function ParseCommonHeaderValue(const HeaderName: THTTPHeaderNameEnum; var Headers: THTTPCommonHeaders): Boolean; procedure ParseSetCookieField(var SetCookie: THTTPSetCookieField); procedure ParseCookieField(var Cookie: THTTPCookieField); function ParseHeader( const ParseEvent: THTTPParserHeaderParseFunc; const HeaderPtr: Pointer; var CommonHeaders: THTTPCommonHeaders; var HeaderName: THTTPHeaderName; var HeaderValue: RawByteString): Boolean; function ParseContent(const Headers: THTTPCommonHeaders): Boolean; procedure ParseRequestMethod(var Method: THTTPMethod); procedure ParseRequestURI(var URI: RawByteString); function ParseRequestStartLine(var StartLine: THTTPRequestStartLine): Boolean; function ParseRequestHeaderValue(const HeaderName: THTTPHeaderNameEnum; const HeaderPtr: Pointer): Boolean; function ParseRequestHeader(var Header: THTTPRequestHeader): Boolean; function ParseRequestContent(var Request: THTTPRequest): Boolean; procedure ParseResponseCode(var Code: Integer); function ParseResponseStartLine(var StartLine: THTTPResponseStartLine): Boolean; function ParseResponseHeaderValue(const HeaderName: THTTPHeaderNameEnum; const HeaderPtr: Pointer): Boolean; function ParseResponseHeader(var Header: THTTPResponseHeader): Boolean; function ParseResponseContent(var Response: THTTPResponse): Boolean; public constructor Create; destructor Destroy; override; procedure SetTextBuf(const Buf; const BufSize: Integer); procedure SetTextStr(const S: RawByteString); procedure ParseRequest(var Request: THTTPRequest); procedure ParseResponse(var Response: THTTPResponse); end; procedure HTTPParseRequest(var Request: THTTPRequest; const Buf; const BufSize: Integer); procedure HTTPParseResponse(var Response: THTTPResponse; const Buf; const BufSize: Integer); { THTTPContentDecoder } type THTTPContentDecoder = class; THTTPContentDecoderReadProc = function (const Sender: THTTPContentDecoder; var Buf; const Size: Integer): Integer of object; THTTPContentDecoderProc = procedure (const Sender: THTTPContentDecoder) of object; THTTPContentDecoderContentProc = procedure (const Sender: THTTPContentDecoder; const Buf; const Size: Integer) of object; THTTPContentDecoderContentType = ( crctFixedSize, crctChunked, crctUnsized); THTTPContentDecoderChunkState = ( crcsChunkHeader, crcsContent, crcsContentCRLF, crcsTrailer, crcsFinished); THTTPContentDecoderLogEvent = procedure (const Sender: THTTPContentDecoder; const LogMsg: String) of object; THTTPContentDecoder = class private FReadProc : THTTPContentDecoderReadProc; FContentProc : THTTPContentDecoderContentProc; FCompleteProc : THTTPContentDecoderProc; FOnLog : THTTPContentDecoderLogEvent; FContentType : THTTPContentDecoderContentType; FContentSize : Int64; FContentReceived : Int64; FContentComplete : Boolean; FChunkState : THTTPContentDecoderChunkState; FChunkBuf : TTCPBuffer; FChunkSize : Int64; FChunkProcessed : Int64; procedure Init; procedure Log(const LogMsg: String); overload; procedure Log(const LogMsg: String; const LogArgs: array of const); overload; procedure TriggerContentBuffer(const Buf; const Size: Integer); procedure TriggerContentComplete; procedure TriggerTrailer(const Hdr: RawByteString); procedure ProcessFixedSize; procedure ProcessUnsized; function ProcessChunked_FillBuf(const Size: Integer): Boolean; function ProcessChunked_FillBufBlock(const Size: Integer): Boolean; function ProcessChunked_FillBufToCRLF(const BlockSize: Integer): Integer; function ProcessChunked_ReadStrToCRLF(const BlockSize: Integer; var Str: RawByteString): Boolean; function ProcessChunked_ExpectCRLF: Boolean; function ProcessChunked_BufferCRLFPosition: Integer; function ProcessChunked_ReadHeader(var HdrStr: RawByteString; var ChunkSize: Int64): Boolean; function ProcessChunked_Header: Boolean; function ProcessChunked_Content: Boolean; function ProcessChunked_ContentCRLF: Boolean; function ProcessChunked_Trailer: Boolean; procedure ProcessChunked_Finalise; procedure ProcessChunked; public constructor Create( const ReadProc: THTTPContentDecoderReadProc; const ContentProc: THTTPContentDecoderContentProc; const CompleteProc: THTTPContentDecoderProc); destructor Destroy; override; property OnLog: THTTPContentDecoderLogEvent read FOnLog write FOnLog; property ContentSize: Int64 read FContentSize; property ContentReceived: Int64 read FContentReceived; property ContentComplete: Boolean read FContentComplete; procedure InitDecoder(const CommonHeaders: THTTPCommonHeaders); procedure Process; end; { THTTPContentReader } type THTTPContentReaderMechanism = ( hcrmEvent, hcrmString, hcrmStream, hcrmFile); THTTPContentReader = class; THTTPContentReaderReadProc = function (const Sender: THTTPContentReader; var Buf; const Size: Integer): Integer of object; THTTPContentReaderContentProc = procedure (const Sender: THTTPContentReader; const Buffer; const Size: Integer) of object; THTTPContentReaderProc = procedure (const Sender: THTTPContentReader) of object; THTTPContentReaderLogEvent = procedure (const Sender: THTTPContentReader; const LogMsg: String; const LogLevel: Integer) of object; THTTPContentReader = class private FReadProc : THTTPContentReaderReadProc; FContentProc : THTTPContentReaderContentProc; FCompleteProc : THTTPContentReaderProc; FOnLog : THTTPContentReaderLogEvent; FMechanism : THTTPContentReaderMechanism; FContentStream : TStream; FContentFileName : String; FContentDecoder : THTTPContentDecoder; FContentStringBuilder : TRawByteStringBuilder; FContentString : RawByteString; FContentFile : TStream; FContentComplete : Boolean; procedure Init; procedure Log(const LogMsg: String; const LogLevel: Integer = 0); overload; procedure Log(const LogMsg: String; const LogArgs: array of const; const LogLevel: Integer = 0); overload; procedure ContentDecoderLog(const Sender: THTTPContentDecoder; const LogMsg: String); function ContentDecoderReadProc(const Sender: THTTPContentDecoder; var Buf; const Size: Integer): Integer; procedure ContentDecoderContentProc(const Sender: THTTPContentDecoder; const Buf; const Size: Integer); procedure ContentDecoderCompleteProc(const Sender: THTTPContentDecoder); procedure InternalReset; function GetContentReceivedSize: Int64; public constructor Create( const ReadProc: THTTPContentReaderReadProc; const ContentProc: THTTPContentReaderContentProc; const CompleteProc: THTTPContentReaderProc); destructor Destroy; override; property OnLog: THTTPContentReaderLogEvent read FOnLog write FOnLog; property Mechanism: THTTPContentReaderMechanism read FMechanism write FMechanism; property ContentStream: TStream read FContentStream write FContentStream; property ContentFileName: String read FContentFileName write FContentFileName; procedure InitReader(const CommonHeaders: THTTPCommonHeaders); procedure Process; property ContentReceivedSize: Int64 read GetContentReceivedSize; property ContentComplete: Boolean read FContentComplete; property ContentString: RawByteString read FContentString; procedure Reset; end; { THTTPContentWriter } type THTTPContentWriterMechanism = ( hctmNone, hctmEvent, hctmString, hctmStream, hctmFile ); THTTPContentWriter = class; THTTPContentWriterWriteProc = function (const Sender: THTTPContentWriter; const Buf; const Size: Integer): Integer of object; THTTPContentWriterLogEvent = procedure (const Sender: THTTPContentWriter; const LogMsg: String) of object; THTTPContentWriter = class private FWriteProc : THTTPContentWriterWriteProc; FOnLog : THTTPContentWriterLogEvent; FMechanism : THTTPContentWriterMechanism; FContentString : RawByteString; FContentStream : TStream; FContentFileName : String; FContentFile : TStream; FContentComplete : Boolean; procedure Init; procedure Log(const LogMsg: String); overload; procedure Log(const LogMsg: String; const Args: array of const); overload; procedure WriteBuf(const Buf; const Size: Integer); procedure WriteStr(const S: RawByteString); procedure InternalReset; public constructor Create(const WriteProc: THTTPContentWriterWriteProc); destructor Destroy; override; property OnLog: THTTPContentWriterLogEvent read FOnLog write FOnLog; property Mechanism: THTTPContentWriterMechanism read FMechanism write FMechanism; property ContentString: RawByteString read FContentString write FContentString; property ContentStream: TStream read FContentStream write FContentStream; property ContentFileName: String read FContentFileName write FContentFileName; procedure InitContent(out HasContent: Boolean; out ContentLength: Int64); procedure SendContent; property ContentComplete: Boolean read FContentComplete; procedure FinaliseContent; procedure Reset; procedure Clear; end; { } { Tests } { } {$IFDEF HTTP_TEST} procedure Test; {$ENDIF} implementation uses { Fundamentals } flcDateTime; { Structure helpers } const HTTP_Space = #32; HTTP_CRLF = #13#10; HTTP_MethodStr : array[THTTPMethodEnum] of RawByteString = ( '', '', 'GET', 'PUT', 'POST', 'CONNECT', 'HEAD', 'DELETE', 'OPTIONS', 'TRACE'); HTTP_HeaderNameList : array[THTTPHeaderNameEnum] of RawByteString = ( '', 'Host', 'Content-Type', 'Content-Length', 'Content-Transfer-Encoding', 'Content-Location', 'Content-Language', 'Content-Encoding', 'Transfer-Encoding', 'Date', 'Server', 'User-Agent', 'Location', 'Connection', 'Expires', 'Cache-Control', 'Set-Cookie', 'Cookie', 'Authorization', 'Via', 'Warning', 'Content-Range', 'X-Forwarded-For', 'Pragma', 'X-Powered-By', 'WWW-Authenticate', 'Last-Modified', 'ETag', 'Proxy-Authorization', 'Referer', 'Age', 'Accept-Ranges', 'Accept-Encoding', 'Accept-Language', 'Accept-Charset', 'If-Modified-Since', 'If-Unmodified-Since', 'Retry-After', 'Upgrade', 'Status', 'Proxy-Connection', 'Origin', 'Keep-Alive'); HTTP_ContentTypeStr : array[THTTPContentTypeEnum] of RawByteString = ( '', '', '', 'text/html', 'text/ascii', 'text/css', 'text/plain', 'text/xml', 'text/', 'image/jpeg', 'image/png', 'image/gif', 'image/x-icon', 'image/', 'application/json', 'application/octet-stream', 'application/javascript', 'application/', 'audio/', 'video/'); HTTP_ContentEncodingStr : array[THTTPContentEncodingEnum] of RawByteString = ( '', '', 'identity', 'compress', 'deflate', 'exi', 'gzip', 'pack200-gzip'); HTTP_StartLineMessage : array[THTTPResponseStartLineMessage] of RawByteString = ( '', '', 'Continue', 'Switching protocols', 'OK', 'Created', 'Accepted', 'Non authoritative information', 'No content', 'Reset content', 'Partial content', 'Multiple choices', 'Moved permanently', 'Found', 'See other', 'Not modified', 'Use proxy', 'Temporary redirect', 'Bad request', 'Unauthorized', 'Payment required', 'Forbidden', 'Not found', 'Method not allowed', 'Not acceptable', 'Proxy authentication required', 'Request timeout', 'Conflict', 'Gone', 'Length required', 'Precondition failed', 'Request entity too large', 'Request URI too long', 'Unsupported media type', 'Requested range not satisfiable', 'Expectation failed', 'Internal server error', 'Not implemented', 'Bad gateway', 'Service unavailable', 'Gateway timeout', 'HTTP version not supported' ); RFC850DayNames : array[1..7] of RawByteString = ( 'Sunday', 'Monday', 'Tuesday', 'Wednesday', 'Thursday', 'Friday', 'Saturday'); RFC1123DayNames : array[1..7] of RawByteString = ( 'Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat'); RFCMonthNames : array[1..12] of RawByteString = ( 'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'); function HTTPResponseCodeToStartLineMessage(const ResponseCode: Integer): THTTPResponseStartLineMessage; begin case ResponseCode of HTTP_ResponseCode_Continue : Result := hslmContinue; HTTP_ResponseCode_SwitchingProtocols : Result := hslmSwitchingProtocols; HTTP_ResponseCode_OK : Result := hslmOK; HTTP_ResponseCode_Created : Result := hslmCreated; HTTP_ResponseCode_Accepted : Result := hslmAccepted; HTTP_ResponseCode_NonAuthoritativeInformation : Result := hslmNonAuthoritativeInformation; HTTP_ResponseCode_NoContent : Result := hslmNoContent; HTTP_ResponseCode_ResetContent : Result := hslmResetContent; HTTP_ResponseCode_PartialContent : Result := hslmPartialContent; HTTP_ResponseCode_MultipleChoices : Result := hslmMultipleChoices; HTTP_ResponseCode_MovedPermanently : Result := hslmMovedPermanently; HTTP_ResponseCode_Found : Result := hslmFound; HTTP_ResponseCode_SeeOther : Result := hslmSeeOther; HTTP_ResponseCode_NotModified : Result := hslmNotModified; HTTP_ResponseCode_UseProxy : Result := hslmUseProxy; HTTP_ResponseCode_TemporaryRedirect : Result := hslmTemporaryRedirect; HTTP_ResponseCode_BadRequest : Result := hslmBadRequest; HTTP_ResponseCode_Unauthorized : Result := hslmUnauthorized; HTTP_ResponseCode_PaymentRequired : Result := hslmPaymentRequired; HTTP_ResponseCode_Forbidden : Result := hslmForbidden; HTTP_ResponseCode_NotFound : Result := hslmNotFound; HTTP_ResponseCode_MethodNotAllowed : Result := hslmMethodNotAllowed; HTTP_ResponseCode_NotAcceptable : Result := hslmNotAcceptable; HTTP_ResponseCode_ProxyAuthenticationRequired : Result := hslmProxyAuthenticationRequired; HTTP_ResponseCode_RequestTimeout : Result := hslmRequestTimeout; HTTP_ResponseCode_Conflict : Result := hslmConflict; HTTP_ResponseCode_Gone : Result := hslmGone; HTTP_ResponseCode_LengthRequired : Result := hslmLengthRequired; HTTP_ResponseCode_PreconditionFailed : Result := hslmPreconditionFailed; HTTP_ResponseCode_RequestEntityTooLarge : Result := hslmRequestEntityTooLarge; HTTP_ResponseCode_RequestURITooLong : Result := hslmRequestURITooLong; HTTP_ResponseCode_UnsupportedMediaType : Result := hslmUnsupportedMediaType; HTTP_ResponseCode_RequestedRangeNotSatisfiable : Result := hslmRequestedRangeNotSatisfiable; HTTP_ResponseCode_ExpectationFailed : Result := hslmExpectationFailed; HTTP_ResponseCode_InternalServerError : Result := hslmInternalServerError; HTTP_ResponseCode_NotImplemented : Result := hslmNotImplemented; HTTP_ResponseCode_BadGateway : Result := hslmBadGateway; HTTP_ResponseCode_ServiceUnavailable : Result := hslmServiceUnavailable; HTTP_ResponseCode_GatewayTimeout : Result := hslmGatewayTimeout; HTTP_ResponseCode_HTTPVersionNotSupported : Result := hslmHTTPVersionNotSupported; else Result := hslmNone; end; end; procedure AddCustomHeader( var CustomHeaders: THTTPCustomHeaders; const HeaderName: RawByteString; const HeaderValue: RawByteString); var L : Integer; begin L := Length(CustomHeaders); SetLength(CustomHeaders, L + 1); CustomHeaders[L].FieldName := HeaderName; CustomHeaders[L].FieldValue := HeaderValue; end; function HTTPMessageHasContent(const H: THTTPCommonHeaders): Boolean; begin if H.ContentLength.Value <> hcltNone then Result := True else if H.ContentType.Value <> hctNone then Result := True else if H.TransferEncoding.Value <> hteNone then Result := True else Result := False; end; { Structure initialise } procedure InitHTTPRequest(var A: THTTPRequest); begin FillChar(A, SizeOf(THTTPRequest), 0); end; procedure InitHTTPResponse(var A: THTTPResponse); begin FillChar(A, SizeOf(THTTPResponse), 0); end; { Structure clear } procedure ClearHTTPVersion(var A: THTTPVersion); begin A.Version := hvNone; A.Protocol := hpNone; A.CustomProtocol := ''; A.CustomMajVersion := 0; A.CustomMinVersion := 0; end; procedure ClearHTTPContentLength(var A: THTTPContentLength); begin A.Value := hcltNone; A.ByteCount := 0; end; procedure ClearHTTPContentType(var A: THTTPContentType); begin A.Value := hctNone; A.CustomMajor := ''; A.CustomMinor := ''; A.Parameters := nil; A.CustomStr := ''; end; procedure ClearHTTPDateField(var A: THTTPDateField); begin A.Value := hdNone; A.DayOfWeek := 0; A.Day := 0; A.Month := 0; A.Year := 0; A.Hour := 0; A.Min := 0; A.Sec := 0; A.TimeZoneGMT := False; A.CustomTimeZone := ''; A.DateTime := 0.0; A.Custom := ''; end; procedure ClearHTTPTransferEncoding(var A: THTTPTransferEncoding); begin A.Value := hteNone; A.Custom := ''; end; procedure ClearHTTPConnectionField(var A: THTTPConnectionField); begin A.Value := hcfNone; A.Custom := ''; end; procedure ClearHTTPAgeField(var A: THTTPAgeField); begin A.Value := hafNone; A.Age := 0; A.Custom := ''; end; procedure ClearHTTPContentEncoding(var A: THTTPContentEncoding); begin A.Value := hceNone; A.Custom := ''; end; procedure ClearHTTPContentEncodingField(var A: THTTPContentEncodingField); begin A.Value := hcefNone; A.List := nil; end; procedure ClearHTTPContentRangeField(var A: THTTPContentRangeField); begin A.Value := hcrfNone; A.ByteFirst := 0; A.ByteLast := 0; A.ByteSize := 0; A.Custom := ''; end; procedure ClearHTTPSetCookieField(var A: THTTPSetCookieField); begin A.Value := hscoNone; A.Domain := ''; A.Path := ''; ClearHTTPDateField(A.Expires); A.MaxAge := 0; A.HttpOnly := False; A.Secure := False; A.CustomFields := nil; A.Custom := ''; end; procedure ClearHTTPCommonHeaders(var A: THTTPCommonHeaders); begin ClearHTTPTransferEncoding(A.TransferEncoding); ClearHTTPContentType(A.ContentType); ClearHTTPContentLength(A.ContentLength); ClearHTTPConnectionField(A.Connection); ClearHTTPConnectionField(A.ProxyConnection); ClearHTTPDateField(A.Date); ClearHTTPContentEncodingField(A.ContentEncoding); end; procedure ClearHTTPFixedHeaders(var A: THTTPFixedHeaders); var I : THTTPHeaderNameEnum; begin for I := Low(THTTPHeaderNameEnum) to High(THTTPHeaderNameEnum) do A[I] := ''; end; procedure ClearHTTPCustomHeaders(var A: THTTPCustomHeaders); begin A := nil; end; procedure ClearHTTPCookieField(var A: THTTPCookieField); begin A.Value := hcoNone; A.Entries := nil; A.Custom := ''; end; procedure ClearHTTPMethod(var A: THTTPMethod); begin A.Value := hmNone; A.Custom := ''; end; procedure ClearHTTPRequestStartLine(var A: THTTPRequestStartLine); begin ClearHTTPMethod(A.Method); A.URI := ''; ClearHTTPVersion(A.Version); end; procedure ClearHTTPRequestHeader(var A: THTTPRequestHeader); begin ClearHTTPCommonHeaders(A.CommonHeaders); ClearHTTPFixedHeaders(A.FixedHeaders); ClearHTTPCustomHeaders(A.CustomHeaders); ClearHTTPCookieField(A.Cookie); ClearHTTPDateField(A.IfModifiedSince); ClearHTTPDateField(A.IfUnmodifiedSince); end; procedure ClearHTTPRequest(var A: THTTPRequest); begin ClearHTTPRequestStartLine(A.StartLine); ClearHTTPRequestHeader(A.Header); A.HeaderComplete := False; A.HasContent := False; end; procedure ClearHTTPResponseStartLine(var A: THTTPResponseStartLine); begin ClearHTTPVersion(A.Version); A.Code := 0; A.Msg := hslmNone; A.CustomMsg := ''; end; procedure ClearHTTPResponseHeader(var A: THTTPResponseHeader); begin ClearHTTPCommonHeaders(A.CommonHeaders); ClearHTTPFixedHeaders(A.FixedHeaders); ClearHTTPCustomHeaders(A.CustomHeaders); A.SetCookies := nil; ClearHTTPDateField(A.Expires); ClearHTTPDateField(A.LastModified); ClearHTTPAgeField(A.Age); end; procedure ClearHTTPResponse(var A: THTTPResponse); begin ClearHTTPResponseStartLine(A.StartLine); ClearHTTPResponseHeader(A.Header); A.HeaderComplete := False; A.HasContent := False; end; { Structure to string } procedure BuildStrHTTPVersion(const A: THTTPVersion; const B: TRawByteStringBuilder; const P: THTTPStringOptions); begin case A.Version of hvNone : ; hvCustom : if A.Protocol <> hpNone then begin case A.Protocol of hpCustom : B.Append(A.CustomProtocol); hpHTTP : B.Append('HTTP'); hpHTTPS : B.Append('HTTPS'); end; B.AppendCh('/'); B.Append(IntToStringB(A.CustomMajVersion)); B.AppendCh('.'); B.Append(IntToStringB(A.CustomMinVersion)); end; hvHTTP10 : B.Append('HTTP/1.0'); hvHTTP11 : B.Append('HTTP/1.1'); end; end; procedure BuildStrHTTPHeaderName(const A: THTTPHeaderNameEnum; const B: TRawByteStringBuilder; const P: THTTPStringOptions); begin B.Append(HTTP_HeaderNameList[A]); B.Append(': '); end; procedure BuildStrHTTPContentLengthValue(const A: THTTPContentLength; const B: TRawByteStringBuilder; const P: THTTPStringOptions); begin case A.Value of hcltNone : ; hcltByteCount : B.Append(IntToStringB(A.ByteCount)); end; end; procedure BuildStrHTTPContentLength(const A: THTTPContentLength; const B: TRawByteStringBuilder; const P: THTTPStringOptions); begin if A.Value = hcltNone then exit; BuildStrHTTPHeaderName(hntContentLength, B, P); BuildStrHTTPContentLengthValue(A, B, P); B.Append(HTTP_CRLF); end; procedure BuildStrHTTPContentTypeValue(const A: THTTPContentType; const B: TRawByteStringBuilder; const P: THTTPStringOptions); var S : RawByteString; I, L : Integer; begin case A.Value of hctNone : exit; hctCustomParts : begin B.Append(A.CustomMajor); B.AppendCh('/'); B.Append(A.CustomMinor); end; hctCustomString : B.Append(A.CustomStr); else begin S := HTTP_ContentTypeStr[A.Value]; if S <> '' then begin B.Append(S); if StrMatchRightB(S, '/') then begin B.Append(A.CustomMinor); end; end; end; end; L := Length(A.Parameters); for I := 0 to L - 1 do begin B.Append('; '); B.Append(A.Parameters[I]); end; end; procedure BuildStrHTTPContentType(const A: THTTPContentType; const B: TRawByteStringBuilder; const P: THTTPStringOptions); begin if A.Value = hctNone then exit; BuildStrHTTPHeaderName(hntContentType, B, P); BuildStrHTTPContentTypeValue(A, B, P); B.Append(HTTP_CRLF); end; procedure BuildStrRFCDateTime( const DOW, Da, Mo, Ye, Ho, Mi, Se: Integer; const TZ: RawByteString; const B: TRawByteStringBuilder; const P: THTTPStringOptions); begin B.Append(RFC1123DayNames[DOW]); B.Append(', '); B.Append(IntToStringB(Da)); B.AppendCh(' '); B.Append(RFCMonthNames[Mo]); B.AppendCh(' '); B.Append(IntToStringB(Ye)); B.AppendCh(' '); B.Append(IntToStringB(Ho)); B.AppendCh(':'); B.Append(IntToStringB(Mi)); B.AppendCh(':'); B.Append(IntToStringB(Se)); B.AppendCh(' '); B.Append(TZ); end; procedure BuildStrHTTPDateFieldValue(const A: THTTPDateField; const B: TRawByteStringBuilder; const P: THTTPStringOptions); var T : TDateTime; Z : RawByteString; Ye, Mo, Da, DOW : Word; Ho, Mi, Se, S1 : Word; begin case A.Value of hdNone : ; hdCustom : B.Append(A.Custom); hdParts : begin if A.TimeZoneGMT then Z := 'GMT' else Z := A.CustomTimeZone; BuildStrRFCDateTime( A.DayOfWeek, A.Day, A.Month, A.Year, A.Hour, A.Min, A.Sec, Z, B, P); end; hdDateTime : begin T := LocalTimeToGMTTime(A.DateTime); DecodeDateFully(T, Ye, Mo, Da, DOW); DecodeTime(T, Ho, Mi, Se, S1); BuildStrRFCDateTime( DOW, Da, Mo, Ye, Ho, Mi, Se, 'GMT', B, P); end; end; end; procedure BuildStrHTTPDateField(const A: THTTPDateField; const B: TRawByteStringBuilder; const P: THTTPStringOptions); begin if A.Value = hdNone then exit; BuildStrHTTPHeaderName(hntDate, B, P); BuildStrHTTPDateFieldValue(A, B, P); B.Append(HTTP_CRLF); end; procedure BuildStrHTTPTransferEncodingValue(const A: THTTPTransferEncoding; const B: TRawByteStringBuilder; const P: THTTPStringOptions); begin case A.Value of hteNone : ; hteCustom : B.Append(A.Custom); hteChunked : B.Append('chunked'); end; end; procedure BuildStrHTTPTransferEncoding(const A: THTTPTransferEncoding; const B: TRawByteStringBuilder; const P: THTTPStringOptions); begin if A.Value = hteNone then exit; BuildStrHTTPHeaderName(hntTransferEncoding, B, P); BuildStrHTTPTransferEncodingValue(A, B, P); B.Append(HTTP_CRLF); end; procedure BuildStrHTTPContentRangeField(const A: THTTPContentRangeField; const B: TRawByteStringBuilder; const P: THTTPStringOptions); begin if A.Value = hcrfNone then exit; BuildStrHTTPHeaderName(hntContentRange, B, P); case A.Value of hcrfCustom : B.Append(A.Custom); hcrfByteRange : begin B.Append(IntToStringB(A.ByteFirst)); B.AppendCh('-'); B.Append(IntToStringB(A.ByteLast)); B.AppendCh('/'); B.Append(IntToStringB(A.ByteSize)); end; end; B.Append(HTTP_CRLF); end; procedure BuildStrHTTPConnectionFieldValue(const A: THTTPConnectionField; const B: TRawByteStringBuilder; const P: THTTPStringOptions); begin case A.Value of hcfNone : ; hcfCustom : B.Append(A.Custom); hcfClose : B.Append('close'); hcfKeepAlive : B.Append('keep-alive'); end; end; procedure BuildStrHTTPConnectionField(const A: THTTPConnectionField; const B: TRawByteStringBuilder; const P: THTTPStringOptions); begin if A.Value = hcfNone then exit; BuildStrHTTPHeaderName(hntConnection, B, P); BuildStrHTTPConnectionFieldValue(A, B, P); B.Append(HTTP_CRLF); end; procedure BuildStrHTTPAgeField(const A: THTTPAgeField; const B: TRawByteStringBuilder; const P: THTTPStringOptions); begin if A.Value = hafNone then exit; BuildStrHTTPHeaderName(hntAge, B, P); case A.Value of hafCustom : B.Append(A.Custom); hafAge : B.Append(IntToStringB(A.Age)); end; B.Append(HTTP_CRLF); end; procedure BuildStrHTTPContentEncoding(const A: THTTPContentEncoding; const B: TRawByteStringBuilder; const P: THTTPStringOptions); begin case A.Value of hceNone : ; hceCustom : B.Append(A.Custom); else B.Append(HTTP_ContentEncodingStr[A.Value]); end; end; procedure BuildStrHTTPContentEncodingField(const A: THTTPContentEncodingField; const B: TRawByteStringBuilder; const P: THTTPStringOptions); var I : Integer; begin if A.Value = hcefNone then exit; BuildStrHTTPHeaderName(hntContentEncoding, B, P); case A.Value of hcefList : for I := 0 to Length(A.List) - 1 do begin if I > 0 then B.Append(', '); BuildStrHTTPContentEncoding(A.List[I], B, P); end; end; B.Append(HTTP_CRLF); end; procedure BuildStrHTTPProxyConnectionField(const A: THTTPConnectionField; const B: TRawByteStringBuilder; const P: THTTPStringOptions); begin if A.Value = hcfNone then exit; BuildStrHTTPHeaderName(hntProxyConnection, B, P); BuildStrHTTPConnectionFieldValue(A, B, P); B.Append(HTTP_CRLF); end; procedure BuildStrHTTPCommonHeaders(const A: THTTPCommonHeaders; const B: TRawByteStringBuilder; const P: THTTPStringOptions); begin BuildStrHTTPTransferEncoding(A.TransferEncoding, B, P); BuildStrHTTPContentType(A.ContentType, B, P); BuildStrHTTPContentLength(A.ContentLength, B, P); BuildStrHTTPConnectionField(A.Connection, B, P); BuildStrHTTPProxyConnectionField(A.ProxyConnection, B, P); BuildStrHTTPDateField(A.Date, B, P); BuildStrHTTPContentEncodingField(A.ContentEncoding, B, P); end; procedure BuildStrHTTPFixedHeaders(const A: THTTPFixedHeaders; const B: TRawByteStringBuilder; const P: THTTPStringOptions); var I : THTTPHeaderNameEnum; S : RawByteString; begin for I := Low(THTTPHeaderNameEnum) to High(THTTPHeaderNameEnum) do begin S := A[I]; if S <> '' then begin B.Append(HTTP_HeaderNameList[I]); B.Append(': '); B.Append(S); B.Append(HTTP_CRLF); end; end; end; procedure BuildStrHTTPCustomHeaders(const A: THTTPCustomHeaders; const B: TRawByteStringBuilder; const P: THTTPStringOptions); var I : Integer; H : PHTTPCustomHeader; begin for I := 0 to Length(A) - 1 do begin H := @A[I]; B.Append(H^.FieldName); B.Append(': '); B.Append(H^.FieldValue); B.Append(HTTP_CRLF); end; end; procedure BuildStrHTTPSetCookieFieldValue(const A: THTTPSetCookieField; const B: TRawByteStringBuilder; const P: THTTPStringOptions); var L : Integer; procedure BuildParam(const F: RawByteString); begin if L > 0 then B.Append('; '); Inc(L); B.Append(F); end; procedure BuildNameValue(const N, V: RawByteString); begin BuildParam(N); B.AppendCh('='); B.Append(V); end; var I : Integer; S : RawByteString; begin case A.Value of hscoNone : ; hscoDecoded : begin L := 0; for I := 0 to Length(A.CustomFields) - 1 do begin BuildParam(A.CustomFields[I].Name); S := A.CustomFields[I].Value; if S <> '' then begin B.AppendCh('='); B.Append(S); end; end; if A.Domain <> '' then BuildNameValue('Domain', A.Domain); if A.Path <> '' then BuildNameValue('Path', A.Path); if A.Expires.Value <> hdNone then begin BuildParam('Expires='); BuildStrHTTPDateFieldValue(A.Expires, B, P); end; if A.MaxAge > 0 then begin BuildParam('Max-Age='); B.Append(IntToStringB(A.MaxAge)); end; if A.HttpOnly then BuildParam('HttpOnly'); if A.Secure then BuildParam('Secure'); end; hscoCustom : B.Append(A.Custom); end; end; procedure BuildStrHTTPCookieFieldValue(const A: THTTPCookieField; const B: TRawByteStringBuilder; const P: THTTPStringOptions); var I : Integer; EntryP : PHTTPCookieFieldEntry; begin case A.Value of hcoNone : ; hcoDecoded : begin for I := 0 to Length(A.Entries) - 1 do begin if I > 0 then B.AppendCh(';'); EntryP := @A.Entries[I]; B.Append(EntryP^.Name); if EntryP^.HasValue then begin B.AppendCh('='); B.Append(EntryP^.Value); end; end; end; hcoCustom : B.Append(A.Custom); end; end; procedure BuildStrHTTPCookieField(const A: THTTPCookieField; const B: TRawByteStringBuilder; const P: THTTPStringOptions); begin if A.Value = hcoNone then exit; BuildStrHTTPHeaderName(hntCookie, B, P); BuildStrHTTPCookieFieldValue(A, B, P); B.Append(HTTP_CRLF); end; procedure BuildStrHTTPIfModifiedSince(const A: THTTPDateField; const B: TRawByteStringBuilder; const P: THTTPStringOptions); begin if A.Value = hdNone then exit; BuildStrHTTPHeaderName(hntIfModifiedSince, B, P); BuildStrHTTPDateFieldValue(A, B, P); B.Append(HTTP_CRLF); end; procedure BuildStrHTTPIfUnmodifiedSince(const A: THTTPDateField; const B: TRawByteStringBuilder; const P: THTTPStringOptions); begin if A.Value = hdNone then exit; BuildStrHTTPHeaderName(hntIfUnmodifiedSince, B, P); BuildStrHTTPDateFieldValue(A, B, P); B.Append(HTTP_CRLF); end; procedure BuildStrHTTPMethod(const A: THTTPMethod; const B: TRawByteStringBuilder; const P: THTTPStringOptions); begin case A.Value of hmNone : ; hmCustom : B.Append(A.Custom); else B.Append(HTTP_MethodStr[A.Value]); end; end; procedure BuildStrHTTPRequestStartLine(const A: THTTPRequestStartLine; const B: TRawByteStringBuilder; const P: THTTPStringOptions); begin BuildStrHTTPMethod(A.Method, B, P); B.AppendCh(' '); B.Append(A.URI); B.AppendCh(' '); BuildStrHTTPVersion(A.Version, B, P); B.Append(HTTP_CRLF); end; procedure BuildStrHTTPRequestHeader(const A: THTTPRequestHeader; const B: TRawByteStringBuilder; const P: THTTPStringOptions); begin BuildStrHTTPCommonHeaders(A.CommonHeaders, B, P); BuildStrHTTPFixedHeaders(A.FixedHeaders, B, P); BuildStrHTTPCustomHeaders(A.CustomHeaders, B, P); BuildStrHTTPCookieField(A.Cookie, B, P); BuildStrHTTPIfModifiedSince(A.IfModifiedSince, B, P); BuildStrHTTPIfUnmodifiedSince(A.IfUnmodifiedSince, B, P); end; procedure BuildStrHTTPRequest(const A: THTTPRequest; const B: TRawByteStringBuilder; const P: THTTPStringOptions); begin BuildStrHTTPRequestStartLine(A.StartLine, B, P); BuildStrHTTPRequestHeader(A.Header, B, P); B.Append(HTTP_CRLF); end; procedure BuildStrHTTPResponseCookieFieldArray(const A: THTTPSetCookieFieldArray; const B: TRawByteStringBuilder; const P: THTTPStringOptions); var I : Integer; begin for I := 0 to Length(A) - 1 do begin BuildStrHTTPHeaderName(hntSetCookie, B, P); BuildStrHTTPSetCookieFieldValue(A[I], B, P); B.Append(HTTP_CRLF); end; end; procedure BuildStrHTTPResponseStartLine(const A: THTTPResponseStartLine; const B: TRawByteStringBuilder; const P: THTTPStringOptions); begin BuildStrHTTPVersion(A.Version, B, P); B.AppendCh(' '); B.Append(IntToStringB(A.Code)); B.AppendCh(' '); case A.Msg of hslmNone : ; hslmCustom : B.Append(A.CustomMsg); else B.Append(HTTP_StartLineMessage[A.Msg]); end; B.Append(HTTP_CRLF); end; procedure BuildStrHTTPResponseHeader(const A: THTTPResponseHeader; const B: TRawByteStringBuilder; const P: THTTPStringOptions); begin BuildStrHTTPCommonHeaders(A.CommonHeaders, B, P); BuildStrHTTPFixedHeaders(A.FixedHeaders, B, P); BuildStrHTTPCustomHeaders(A.CustomHeaders, B, P); BuildStrHTTPResponseCookieFieldArray(A.SetCookies, B, P); // A.Expires // A.LastModified BuildStrHTTPAgeField(A.Age, B, P); end; procedure BuildStrHTTPResponse(const A: THTTPResponse; const B: TRawByteStringBuilder; const P: THTTPStringOptions); begin BuildStrHTTPResponseStartLine(A.StartLine, B, P); BuildStrHTTPResponseHeader(A.Header, B, P); B.Append(HTTP_CRLF); end; function HTTPContentTypeValueToStr(const A: THTTPContentType): RawByteString; var B : TRawByteStringBuilder; begin B := TRawByteStringBuilder.Create; try BuildStrHTTPContentTypeValue(A, B, []); Result := B.AsRawByteString; finally B.Free; end; end; function HTTPSetCookieFieldValueToStr(const A: THTTPSetCookieField): RawByteString; var B : TRawByteStringBuilder; begin B := TRawByteStringBuilder.Create; try BuildStrHTTPSetCookieFieldValue(A, B, []); Result := B.AsRawByteString; finally B.Free; end; end; function HTTPCookieFieldValueToStr(const A: THTTPCookieField): RawByteString; var B : TRawByteStringBuilder; begin B := TRawByteStringBuilder.Create; try BuildStrHTTPCookieFieldValue(A, B, []); Result := B.AsRawByteString; finally B.Free; end; end; function HTTPMethodToStr(const A: THTTPMethod): RawByteString; var B : TRawByteStringBuilder; begin B := TRawByteStringBuilder.Create; try BuildStrHTTPMethod(A, B, []); Result := B.AsRawByteString; finally B.Free; end; end; function HTTPRequestToStr(const A: THTTPRequest): RawByteString; var B : TRawByteStringBuilder; begin B := TRawByteStringBuilder.Create; try BuildStrHTTPRequest(A, B, []); Result := B.AsRawByteString; finally B.Free; end; end; function HTTPResponseToStr(const A: THTTPResponse): RawByteString; var B : TRawByteStringBuilder; begin B := TRawByteStringBuilder.Create; try BuildStrHTTPResponse(A, B, []); Result := B.AsRawByteString; finally B.Free; end; end; { Cookies } function GetHTTPCookieFieldEntryIndexByName(const A: THTTPCookieFieldEntryArray; const Name: RawByteString): Integer; var I : Integer; begin for I := 0 to Length(A) - 1 do if StrEqualNoAsciiCaseB(A[I].Name, Name) then begin Result := I; exit; end; Result := -1; end; function GetHTTPCookieFieldEntryValueByName(const A: THTTPCookieFieldEntryArray; const Name: RawByteString; const Default: RawByteString): RawByteString; var I : Integer; begin I := GetHTTPCookieFieldEntryIndexByName(A, Name); if I < 0 then Result := Default else Result := A[I].Value; end; procedure PrepareCookie(var A: THTTPCookieField; const B: THTTPSetCookieFieldArray; const Domain: RawByteString; const Secure: Boolean); var I, J, T, L : Integer; F : PHTTPSetCookieField; G : PHTTPSetCookieCustomField; H : PHTTPCookieFieldEntry; begin ClearHTTPCookieField(A); A.Value := hcoDecoded; for I := 0 to Length(B) - 1 do begin F := @B[I]; if F^.Secure = Secure then if StrEqualNoAsciiCaseB(F^.Domain, Domain) then for J := 0 to Length(F^.CustomFields) - 1 do begin G := @F^.CustomFields[J]; T := GetHTTPCookieFieldEntryIndexByName(A.Entries, G^.Name); if T < 0 then begin L := Length(A.Entries); SetLength(A.Entries, L + 1); H := @A.Entries[L]; H^.Name := G^.Name; H^.Value := G^.Value; end else begin H := @A.Entries[T]; H^.Value := G^.Value; end; end; end; end; procedure HTTPSetCookieFieldInitDecoded(var A: THTTPSetCookieField; Path, Domain: RawByteString); begin ClearHTTPSetCookieField(A); A.Value := hscoDecoded; A.Path := Path; A.Domain := Domain; end; procedure HTTPSetCookieFieldAddCustomField(var A: THTTPSetCookieField; const Name, Value : RawByteString); var L : Integer; P : PHTTPSetCookieCustomField; begin L := Length(A.CustomFields); SetLength(A.CustomFields, L + 1); P := @A.CustomFields[L]; P^.Name := Name; P^.Value := Value; end; function HTTPCustomHeadersAdd(var A: THTTPCustomHeaders): PHTTPCustomHeader; var L : Integer; P : PHTTPCustomHeader; begin L := Length(A); SetLength(A, L + 1); P := @A[L]; Result := P; end; function HTTPCustomHeadersAdd(var A: THTTPCustomHeaders; const FieldName: RawByteString): PHTTPCustomHeader; var P : PHTTPCustomHeader; begin P := HTTPCustomHeadersAdd(A); P^.FieldName := FieldName; Result := P; end; function HTTPCustomHeadersAdd(var A: THTTPCustomHeaders; const FieldName, FieldValue: RawByteString): PHTTPCustomHeader; var P : PHTTPCustomHeader; begin P := HTTPCustomHeadersAdd(A, FieldName); P^.FieldValue := FieldValue; Result := P; end; function HTTPCustomHeadersGetByName(const A: THTTPCustomHeaders; const FieldName: RawByteString): PHTTPCustomHeader; var I : Integer; P : PHTTPCustomHeader; begin for I := 0 to Length(A) - 1 do begin P := @A[I]; if StrEqualNoAsciiCaseB(FieldName, P^.FieldName) then begin Result := P; exit; end; end; Result := nil; end; { Url encoded } function HTTPUrlEncodedUnescapeStr(const S: RawByteString): RawByteString; var R : RawByteString; begin R := StrReplaceCharB('+', HTTP_Space, S); R := StrHexUnescapeB(R, '%'); Result := R; end; procedure HTTPUrlEncodedDecode(const S: RawByteString; out Fields: THTTPUrlEncodedFieldArray); var FieldsStrArr : flcStdTypes.RawByteStringArray; FieldCount, I : Integer; FieldStr, Name, Value : RawByteString; FieldP : PHTTPUrlEncodedField; begin FieldsStrArr := StrSplitCharB(S, '&'); FieldCount := Length(FieldsStrArr); SetLength(Fields, FieldCount); for I := 0 to FieldCount - 1 do begin FieldStr := FieldsStrArr[I]; StrSplitAtCharB(FieldStr, '=', Name, Value, True); Name := HTTPUrlEncodedUnescapeStr(Name); Value := HTTPUrlEncodedUnescapeStr(Value); FieldP := @Fields[I]; FieldP^.Name := Name; FieldP^.Value := Value; end; end; function HTTPUrlEncodedFieldsGetFieldPtrByName(const Fields: THTTPUrlEncodedFieldArray; const Name: RawByteString): PHTTPUrlEncodedField; var I : Integer; F : PHTTPUrlEncodedField; begin for I := 0 to Length(Fields) - 1 do begin F := @Fields[I]; if StrEqualNoAsciiCaseB(F^.Name, Name) then begin Result := F; exit; end; end; Result := nil; end; function HTTPUrlEncodedFieldsGetStrByName(const Fields: THTTPUrlEncodedFieldArray; const Name: RawByteString; const Default: RawByteString): RawByteString; var F : PHTTPUrlEncodedField; begin F := HTTPUrlEncodedFieldsGetFieldPtrByName(Fields, Name); if Assigned(F) then Result := F^.Value else Result := Default; end; function HTTPUrlEncodedFieldsGetIntByName(const Fields: THTTPUrlEncodedFieldArray; const Name: RawByteString; const Default: Int64): Int64; var F : PHTTPUrlEncodedField; begin F := HTTPUrlEncodedFieldsGetFieldPtrByName(Fields, Name); if Assigned(F) then Result := StringToInt64DefB(F^.Value, Default) else Result := Default; end; { Content type } function HTTPWellKnownFileExtenstionToContentType(const Extension: RawByteString): THTTPContentTypeEnum; var R : THTTPContentTypeEnum; begin if StrEqualNoAsciiCaseB(Extension, '.htm') or StrEqualNoAsciiCaseB(Extension, '.html') then R := hctTextHtml else if StrEqualNoAsciiCaseB(Extension, '.txt') then R := hctTextAscii else if StrEqualNoAsciiCaseB(Extension, '.css') then R := hctTextCss else if StrEqualNoAsciiCaseB(Extension, '.xml') then R := hctTextXml else if StrEqualNoAsciiCaseB(Extension, '.jpg') or StrEqualNoAsciiCaseB(Extension, '.jpeg') then R := hctImageJpeg else if StrEqualNoAsciiCaseB(Extension, '.png') then R := hctImagePng else if StrEqualNoAsciiCaseB(Extension, '.gif') then R := hctImageGif else if StrEqualNoAsciiCaseB(Extension, '.ico') then R := hctImageIcon else if StrEqualNoAsciiCaseB(Extension, '.js') then R := hctApplicationJavaScript else if StrEqualNoAsciiCaseB(Extension, '.json') then R := hctApplicationJSON else R := hctNone; Result := R; end; { HTTP parser helpers } const HTTP_SpaceSet : ByteCharSet = [' ']; HTTP_DelimSet : ByteCharSet = [' ', #13]; HTTP_FieldValueDelimSet : ByteCharSet = [#13]; HTTP_CRSet : ByteCharSet = [#13]; { THTTPParser } const SHTTPErr_InvalidParameter = 'Invalid parameter'; constructor THTTPParser.Create; begin inherited Create; end; destructor THTTPParser.Destroy; begin inherited Destroy; end; procedure THTTPParser.SetTextBuf(const Buf; const BufSize: Integer); begin if BufSize < 0 then raise EHTTPParser.Create(SHTTPErr_InvalidParameter); FBufPtr := @Buf; FBufSize := BufSize; FBufPos := 0; FBufStrRef := ''; end; procedure THTTPParser.SetTextStr(const S: RawByteString); begin FBufStrRef := S; FBufSize := Length(S); FBufPtr := PByte(FBufStrRef); FBufPos := 0; end; function THTTPParser.EOF: Boolean; begin Result := FBufPos >= FBufSize; end; function THTTPParser.MatchCh(const C: ByteCharSet): Boolean; var N, F : Integer; P : PByteChar; begin if C = [] then begin Result := False; exit; end; F := FBufPos; N := FBufSize - F; if N < 1 then begin Result := False; exit; end; P := FBufPtr; Inc(P, F); Result := P^ in C; end; function THTTPParser.MatchStrAndCh(const S: RawByteString; const CaseSensitive: Boolean; const C: ByteCharSet): Boolean; var L, T, N, F : Integer; P : PByteChar; D : Boolean; begin D := C <> []; L := Length(S); T := L; if D then Inc(T); if T = 0 then begin Result := False; exit; end; F := FBufPos; N := FBufSize - F; if N < T then begin Result := False; exit; end; P := FBufPtr; Inc(P, F); if L > 0 then begin if CaseSensitive then Result := SysUtils.CompareMem(Pointer(S), P, L) else Result := StrPMatchNoAsciiCaseB(Pointer(S), Pointer(P), L); if not Result then exit; end else Result := True; if D then begin Inc(P, L); if not (P^ in C) then Result := False; end; end; function THTTPParser.MatchStr(const S: RawByteString; const CaseSensitive: Boolean): Boolean; begin Result := MatchStrAndCh(S, CaseSensitive, []); end; function THTTPParser.SkipStrAndCh(const S: RawByteString; const DelimSet: ByteCharSet; const SkipDelim: Boolean; const CaseSensitive: Boolean): Boolean; var L : Integer; begin Result := MatchStrAndCh(S, CaseSensitive, DelimSet); if not Result then exit; L := Length(S); if SkipDelim then if DelimSet <> [] then Inc(L); Inc(FBufPos, L); end; function THTTPParser.SkipCh(const C: ByteCharSet): Boolean; var N, F : Integer; P : PByteChar; begin F := FBufPos; N := FBufSize - F; if N <= 0 then begin Result := False; exit; end; P := FBufPtr; Inc(P, F); if P^ in C then begin Inc(FBufPos); Result := True; end else Result := False; end; function THTTPParser.SkipAllCh(const C: ByteCharSet): Boolean; var N, L, F : Integer; P : PByteChar; begin L := 0; F := FBufPos; N := FBufSize - F; P := FBufPtr; Inc(P, F); while N > 0 do if P^ in C then begin Inc(P); Dec(N); Inc(L); end else break; if L > 0 then begin Inc(FBufPos, L); Result := True; end else Result := False; end; function THTTPParser.SkipToStr(const S: RawByteString; const CaseSensitive: Boolean): Boolean; var N, L, F, C : Integer; P : PByteChar; R, T : Boolean; begin L := Length(S); F := FBufPos; N := FBufSize - F; P := FBufPtr; Inc(P, F); R := False; C := 0; while N >= L do begin if CaseSensitive then T := SysUtils.CompareMem(PByteChar(S), P, L) else T := StrPMatchNoAsciiCaseB(Pointer(S), Pointer(P), L); if T then break; Dec(N); Inc(P); Inc(C); R := True; end; Inc(FBufPos, C); Result := R; end; function THTTPParser.SkipCRLF: Boolean; begin Result := SkipStrAndCh(HTTP_CRLF, [], False, True); end; function THTTPParser.SkipSpace: Boolean; begin Result := SkipAllCh(HTTP_SpaceSet); end; function THTTPParser.SkipLWS: Boolean; var R, T : Boolean; begin R := False; repeat T := SkipSpace; if SkipStrAndCh(HTTP_CRLF, [#9, #32], True, True) then T := True; if T then R := True; until not T or EOF; Result := R; end; function THTTPParser.SkipToCRLF: Boolean; begin Result := SkipToStr(HTTP_CRLF, False); end; function THTTPParser.ExtractAllCh(const C: ByteCharSet): RawByteString; var N, L : Integer; P, Q : PByteChar; D : AnsiChar; R : Boolean; S : RawByteString; begin P := FBufPtr; Inc(P, FBufPos); Q := P; N := FBufSize - FBufPos; L := 0; while N > 0 do begin D := P^; R := D in C; if not R then break else Inc(L); Inc(P); Dec(N); end; SetLength(S, L); if L > 0 then Move(Q^, S[1], L); Inc(FBufPos, L); Result := S; end; function THTTPParser.ExtractTo(const C: ByteCharSet; var S: RawByteString; const SkipDelim: Boolean): AnsiChar; var N, L : Integer; P, Q : PByteChar; D : AnsiChar; R : Boolean; begin P := FBufPtr; Inc(P, FBufPos); Q := P; N := FBufSize - FBufPos; L := 0; R := False; D := #0; while N > 0 do begin D := P^; R := D in C; if R then break else Inc(L); Inc(P); Dec(N); end; SetLength(S, L); if L > 0 then Move(Q^, S[1], L); Inc(FBufPos, L); if R and SkipDelim then Inc(FBufPos); Result := D; end; function THTTPParser.ExtractStrTo(const C: ByteCharSet; const SkipDelim: Boolean): RawByteString; begin ExtractTo(C, Result, SkipDelim); end; function THTTPParser.ExtractInt(const Default: Int64): Int64; var S : RawByteString; begin S := ExtractAllCh(['0'..'9']); if not TryStringToInt64B(S, Result) then Result := Default; end; function THTTPParser.ExtractIntTo(const C: ByteCharSet; const SkipDelim: Boolean; const Default: Int64): Int64; var S : RawByteString; begin ExtractTo(C, S, SkipDelim); if not TryStringToInt64B(S, Result) then Result := Default; end; procedure THTTPParser.ParseCustomVersion(var Protocol: THTTPVersion); begin if SkipStrAndCh('HTTP/', [], False, False) then Protocol.Protocol := hpHTTP else if SkipStrAndCh('HTTPS/', [], False, False) then Protocol.Protocol := hpHTTPS else begin Protocol.Protocol := hpCustom; Protocol.CustomProtocol := ExtractStrTo(['/', #13], False); SkipCh(['/']); end; Protocol.CustomMajVersion := ExtractIntTo(['.', #13], False, -1); if SkipCh(['.']) then Protocol.CustomMinVersion := ExtractInt(-1) else Protocol.CustomMinVersion := -1; end; procedure THTTPParser.ParseVersion(var Version: THTTPVersion); begin ClearHTTPVersion(Version); if SkipStrAndCh('HTTP/1.1', HTTP_DelimSet, False, False) then Version.Version := hvHTTP11 else if SkipStrAndCh('HTTP/1.0', HTTP_DelimSet, False, False) then Version.Version := hvHTTP10 else begin Version.Version := hvCustom; ParseCustomVersion(Version); end; end; procedure THTTPParser.ParseHeaderName(var HeaderName: THTTPHeaderName); const HTTP_HeaderNameDelimSet : ByteCharSet = [' ', #9, ':', #13]; var I : THTTPHeaderNameEnum; S : RawByteString; begin for I := Low(THTTPHeaderNameEnum) to High(THTTPHeaderNameEnum) do begin S := HTTP_HeaderNameList[I]; if S <> '' then if SkipStrAndCh(S, HTTP_HeaderNameDelimSet, False, False) then begin HeaderName.Value := I; HeaderName.Custom := ''; exit; end; end; HeaderName.Value := hntCustom; HeaderName.Custom := ExtractStrTo(HTTP_HeaderNameDelimSet, False); end; procedure THTTPParser.ParseHeaderValue(var HeaderValue: RawByteString); var S : RawByteString; R : Boolean; begin S := ''; R := False; repeat S := S + ExtractStrTo(HTTP_CRSet, False); SkipLWS; if MatchStr(HTTP_CRLF, True) then R := True else if SkipCh(HTTP_CRSet) then S := S + #13; until R or EOF; HeaderValue := S; end; procedure THTTPParser.ParseTransferEncoding(var Value: THTTPTransferEncoding); begin Value.Custom := ''; if SkipStrAndCh('chunked', HTTP_FieldValueDelimSet, False, False) then Value.Value := hteChunked else begin Value.Value := hteCustom; ParseHeaderValue(Value.Custom); end; end; { Content-Type = "Content-Type" ":" media-type } { media-type = type "/" subtype *( ";" parameter ) } procedure THTTPParser.ParseContentType(var Value: THTTPContentType); const HTTP_ContentTypeDelimSet = [' ', #9, #13, ';']; var I : THTTPContentTypeEnum; S : RawByteString; L : Integer; begin ClearHTTPContentType(Value); for I := Low(THTTPContentTypeEnum) to High(THTTPContentTypeEnum) do begin S := HTTP_ContentTypeStr[I]; if (S <> '') and not StrMatchRightB(S, '/') then if SkipStrAndCh(S, HTTP_ContentTypeDelimSet, False, False) then begin Value.Value := I; break; end; end; if Value.Value = hctNone then begin if SkipStrAndCh('text/', [], False, False) then Value.Value := hctTextCustom else if SkipStrAndCh('image/', [], False, False) then Value.Value := hctImageCustom else if SkipStrAndCh('application/', [], False, False) then Value.Value := hctApplicationCustom else if SkipStrAndCh('audio/', [], False, False) then Value.Value := hctAudioCustom else if SkipStrAndCh('video/', [], False, False) then Value.Value := hctVideoCustom else begin Value.Value := hctCustomParts; Value.CustomMajor := ExtractStrTo(['/'], True); Value.CustomMinor := ExtractStrTo(HTTP_ContentTypeDelimSet, False); end; end; if Value.Value in [ hctTextCustom, hctImageCustom, hctApplicationCustom, hctAudioCustom] then Value.CustomMinor := ExtractStrTo(HTTP_ContentTypeDelimSet, False); SkipLWS; L := 0; while SkipCh([';']) do begin SkipLWS; SetLength(Value.Parameters, L + 1); Value.Parameters[L] := ExtractStrTo(HTTP_DelimSet, False); Inc(L); SkipLWS; end; end; { "Content-Length" ":" 1*DIGIT } procedure THTTPParser.ParseContentLength(var Value: THTTPContentLength); begin Value.Value := hcltByteCount; Value.ByteCount := ExtractInt(-1); end; { "Connection" ":" 1#(connection-token) } procedure THTTPParser.ParseConnectionField(var Value: THTTPConnectionField); begin Value.Custom := ''; if SkipStrAndCh('close', HTTP_FieldValueDelimSet, False, False) then Value.Value := hcfClose else if SkipStrAndCh('keep-alive', HTTP_FieldValueDelimSet, False, False) then Value.Value := hcfKeepAlive else begin Value.Value := hcfCustom; ParseHeaderValue(Value.Custom); end; end; { Sun, 06 Nov 1994 08:49:37 GMT ; RFC 822, updated by RFC 1123 Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036 Sun Nov 6 08:49:37 1994 ; ANSI C's asctime() format // not supported } procedure THTTPParser.ParseDateField(var Value: THTTPDateField); const HTTP_DayNameDelim = [',', ' ']; var I : Integer; D, T : TDateTime; begin ClearHTTPDateField(Value); for I := 1 to 7 do if SkipStrAndCh(RFC850DayNames[I], HTTP_DayNameDelim, True, False) then begin Value.DayOfWeek := I; break; end; if Value.DayOfWeek = 0 then for I := 1 to 7 do if SkipStrAndCh(RFC1123DayNames[I], HTTP_DayNameDelim, True, False) then begin Value.DayOfWeek := I; break; end; if Value.DayOfWeek > 0 then begin Value.Value := hdParts; SkipSpace; Value.Day := ExtractInt(0); SkipSpace; SkipCh(['-']); SkipSpace; for I := 1 to 12 do if SkipStrAndCh(RFCMonthNames[I], [' ', '-'], False, False) then begin SkipSpace; SkipCh(['-']); Value.Month := I; break; end; SkipSpace; Value.Year := ExtractInt(0); SkipSpace; Value.Hour := ExtractInt(0); SkipSpace; SkipCh([':']); SkipSpace; Value.Min := ExtractInt(0); SkipSpace; SkipCh([':']); SkipSpace; Value.Sec := ExtractInt(0); SkipSpace; if SkipStrAndCh('GMT', [';', ' ', #13], False, False) then Value.TimeZoneGMT := True else Value.CustomTimeZone := ExtractStrTo(HTTP_FieldValueDelimSet, False); if not TryEncodeDate(Value.Year, Value.Month, Value.Day, D) then D := 0.0; if not TryEncodeTime(Value.Hour, Value.Min, Value.Sec, 0, T) then T := 0.0; Value.DateTime := D + T; end else begin Value.Value := hdCustom; ParseHeaderValue(Value.Custom); end; end; procedure THTTPParser.ParseAgeField(var Value: THTTPAgeField); begin ClearHTTPAgeField(Value); if MatchCh(['0'..'9']) then begin Value.Value := hafAge; Value.Age := ExtractInt(-1); end else begin Value.Value := hafCustom; Value.Custom := ExtractStrTo(HTTP_DelimSet, False); end; end; { Content-Encoding = "Content-Encoding" ":" 1#content-coding } procedure THTTPParser.ParseContentEncoding(var Value: THTTPContentEncoding); var I, E : THTTPContentEncodingEnum; S : RawByteString; begin ClearHTTPContentEncoding(Value); E := hceNone; for I := Low(THTTPContentEncodingEnum) to High(THTTPContentEncodingEnum) do begin S := HTTP_ContentEncodingStr[I]; if S <> '' then if SkipStrAndCh(S, [#13, ' ', ','], False, False) then begin E := I; break; end; end; if E = hceNone then begin S := ExtractStrTo([#13, ' ', ','], False); if S <> '' then begin E := hceCustom; Value.Custom := S; end; end; Value.Value := E; end; procedure THTTPParser.ParseContentEncodingField(var Value: THTTPContentEncodingField); var E : THTTPContentEncoding; L : Integer; R : Boolean; begin ClearHTTPContentEncodingField(Value); L := 0; repeat SkipLWS; ParseContentEncoding(E); if E.Value = hceNone then R := False else begin SetLength(Value.List, L + 1); Value.List[L] := E; Inc(L); SkipLWS; R := SkipCh([',']); end; until not R; Value.Value := hcefList; end; function THTTPParser.ParseCommonHeaderValue(const HeaderName: THTTPHeaderNameEnum; var Headers: THTTPCommonHeaders): Boolean; var R : Boolean; begin R := True; case HeaderName of hntTransferEncoding : ParseTransferEncoding(Headers.TransferEncoding); hntContentType : ParseContentType(Headers.ContentType); hntContentLength : ParseContentLength(Headers.ContentLength); hntConnection : ParseConnectionField(Headers.Connection); hntProxyConnection : ParseConnectionField(Headers.ProxyConnection); hntDate : ParseDateField(Headers.Date); hntContentEncoding : ParseContentEncodingField(Headers.ContentEncoding); else R := False; end; Result := R; end; { Set-Cookie: LSID=DQAAAK…Eaem_vYg; Domain=docs.foo.com; Path=/accounts; Expires=Wed, 13-Jan-2021 22:23:01 GMT; Secure; HttpOnly Set-Cookie: PHPSESSID=4234b9b46c7d355416fc5366b529bdd1; path=/; domain=.mtgox.com; secure; HttpOnly } type THTTPSetCookieSubField = ( scsfNone, scsfCustom, scsfDomain, scsfPath, scsfExpires, scsfMaxAge); procedure THTTPParser.ParseSetCookieField(var SetCookie: THTTPSetCookieField); var R : Boolean; F : THTTPSetCookieSubField; FieldName : RawByteString; FieldValue : RawByteString; L : Integer; begin ClearHTTPSetCookieField(SetCookie); SetCookie.Value := hscoDecoded; repeat SkipLWS; R := True; if SkipStrAndCh('HttpOnly', [';', #13, ' '], False, False) then SetCookie.HttpOnly := True else if SkipStrAndCh('Secure', [';', #13, ' '], False, False) then SetCookie.Secure := True else R := False; if not R then begin if SkipStrAndCh('Domain', ['=', ';', #13, ' '], False, False) then F := scsfDomain else if SkipStrAndCh('Path', ['=', ';', #13, ' '], False, False) then F := scsfPath else if SkipStrAndCh('Expires', ['=', ';', #13, ' '], False, False) then F := scsfExpires else if SkipStrAndCh('Max-Age', ['=', ';', #13, ' '], False, False) then F := scsfMaxAge else F := scsfNone; if F = scsfNone then begin FieldName := ExtractStrTo(['=', #13, ';', ' '], False); F := scsfCustom; end; SkipLWS; if SkipCh(['=']) then begin SkipLWS; case F of scsfExpires : ParseDateField(SetCookie.Expires); else FieldValue := ExtractStrTo([#13, ';', ' '], False); end; end else FieldValue := ''; case F of scsfDomain : SetCookie.Domain := FieldValue; scsfPath : SetCookie.Path := FieldValue; scsfMaxAge : SetCookie.MaxAge := StringToInt64DefB(FieldValue, -1); scsfCustom : begin L := Length(SetCookie.CustomFields); SetLength(SetCookie.CustomFields, L + 1); SetCookie.CustomFields[L].Name := FieldName; SetCookie.CustomFields[L].Value := FieldValue; end; end; end; SkipLWS; SkipCh([';']); until EOF or MatchCh([#13]); end; procedure THTTPParser.ParseCookieField(var Cookie: THTTPCookieField); var FieldName : RawByteString; FieldValue : RawByteString; FieldHasValue : Boolean; L : Integer; FieldEntryP : PHTTPCookieFieldEntry; begin ClearHTTPCookieField(Cookie); Cookie.Value := hcoDecoded; L := 0; repeat SkipLWS; FieldName := ExtractStrTo(['=', #13, ';', ' '], False); SkipLWS; if SkipCh(['=']) then begin FieldHasValue := True; SkipLWS; FieldValue := ExtractStrTo([#13, ';', ' '], False); SkipLWS; end else begin FieldHasValue := False; FieldValue := ''; end; if SkipCh([';']) then SkipLWS; SetLength(Cookie.Entries, L + 1); FieldEntryP := @Cookie.Entries[L]; Inc(L); FieldEntryP^.Name := FieldName; FieldEntryP^.HasValue := FieldHasValue; FieldEntryP^.Value := FieldValue; until EOF or MatchCh([#13]); end; function THTTPParser.ParseHeader( const ParseEvent: THTTPParserHeaderParseFunc; const HeaderPtr: Pointer; var CommonHeaders: THTTPCommonHeaders; var HeaderName: THTTPHeaderName; var HeaderValue: RawByteString): Boolean; begin HeaderValue := ''; ParseHeaderName(HeaderName); SkipLWS; if SkipCh([':']) then begin SkipLWS; if not ParseCommonHeaderValue(HeaderName.Value, CommonHeaders) then if not ParseEvent(HeaderName.Value, HeaderPtr) then ParseHeaderValue(HeaderValue); SkipLWS; end; SkipToCRLF; Result := SkipCRLF; end; function THTTPParser.ParseContent(const Headers: THTTPCommonHeaders): Boolean; begin Result := HTTPMessageHasContent(Headers); if not Result then exit; if EOF then exit; end; function THTTPParser.ParseRequestHeaderValue(const HeaderName: THTTPHeaderNameEnum; const HeaderPtr: Pointer): Boolean; var Hdr : PHTTPRequestHeader; R : Boolean; begin Hdr := HeaderPtr; R := True; case HeaderName of hntIfModifiedSince : ParseDateField(Hdr^.IfModifiedSince); hntIfUnmodifiedSince : ParseDateField(Hdr^.IfUnmodifiedSince); hntCookie : ParseCookieField(Hdr^.Cookie); else R := False; end; Result := R; end; function THTTPParser.ParseRequestHeader(var Header: THTTPRequestHeader): Boolean; var R : Boolean; N : THTTPHeaderName; V : RawByteString; begin repeat ParseHeader(ParseRequestHeaderValue, @Header, Header.CommonHeaders, N, V); case N.Value of hntCustom : AddCustomHeader(Header.CustomHeaders, N.Custom, V); else Header.FixedHeaders[N.Value] := V; end; R := SkipCRLF; until R or EOF; Result := R; end; function THTTPParser.ParseRequestContent(var Request: THTTPRequest): Boolean; begin Result := Request.HeaderComplete; if not Result then exit; Result := ParseContent(Request.Header.CommonHeaders); end; procedure THTTPParser.ParseRequestMethod(var Method: THTTPMethod); var I : THTTPMethodEnum; S : RawByteString; begin ClearHTTPMethod(Method); for I := Low(THTTPMethodEnum) to High(THTTPMethodEnum) do begin S := HTTP_MethodStr[I]; if S <> '' then if SkipStrAndCh(S, HTTP_SpaceSet, False, False) then begin Method.Value := I; exit; end; end; Method.Value := hmCustom; Method.Custom := ExtractStrTo(HTTP_SpaceSet, False); end; procedure THTTPParser.ParseRequestURI(var URI: RawByteString); begin URI := ExtractStrTo([' ', #13], False); end; function THTTPParser.ParseRequestStartLine(var StartLine: THTTPRequestStartLine): Boolean; begin ParseRequestMethod(StartLine.Method); SkipSpace; ParseRequestURI(StartLine.URI); SkipSpace; ParseVersion(StartLine.Version); Result := SkipCRLF; end; procedure THTTPParser.ParseRequest(var Request: THTTPRequest); begin ParseRequestStartLine(Request.StartLine); Request.HeaderComplete := ParseRequestHeader(Request.Header); Request.HasContent := ParseRequestContent(Request); end; procedure THTTPParser.ParseResponseCode(var Code: Integer); begin Code := ExtractIntTo(HTTP_SpaceSet, False, -1); end; function THTTPParser.ParseResponseStartLine(var StartLine: THTTPResponseStartLine): Boolean; begin ParseVersion(StartLine.Version); SkipSpace; ParseResponseCode(StartLine.Code); SkipSpace; if SkipStrAndCh('OK', HTTP_CRSet, False, True) then begin StartLine.Msg := hslmOK; StartLine.CustomMsg := ''; end else begin StartLine.Msg := hslmCustom; StartLine.CustomMsg := ExtractStrTo(HTTP_CRSet, False); end; Result := SkipCRLF; end; function THTTPParser.ParseResponseHeaderValue(const HeaderName: THTTPHeaderNameEnum; const HeaderPtr: Pointer): Boolean; var Hdr : PHTTPResponseHeader; R : Boolean; L : Integer; begin Hdr := HeaderPtr; R := True; case HeaderName of hntExpires : ParseDateField(Hdr^.Expires); hntLastModified : ParseDateField(Hdr^.LastModified); hntAge : ParseAgeField(Hdr^.Age); hntSetCookie : begin L := Length(Hdr^.SetCookies); SetLength(Hdr^.SetCookies, L + 1); ParseSetCookieField(Hdr^.SetCookies[L]); end; else R := False; end; Result := R; end; function THTTPParser.ParseResponseHeader(var Header: THTTPResponseHeader): Boolean; var R : Boolean; N : THTTPHeaderName; V : RawByteString; begin repeat ParseHeader(ParseResponseHeaderValue, @Header, Header.CommonHeaders, N, V); case N.Value of hntCustom : AddCustomHeader(Header.CustomHeaders, N.Custom, V); else Header.FixedHeaders[N.Value] := V; end; R := SkipCRLF; until R or EOF; Result := R; end; function THTTPParser.ParseResponseContent(var Response: THTTPResponse): Boolean; begin Result := Response.HeaderComplete; if not Result then exit; Result := ParseContent(Response.Header.CommonHeaders); end; procedure THTTPParser.ParseResponse(var Response: THTTPResponse); begin ParseResponseStartLine(Response.StartLine); Response.HeaderComplete := ParseResponseHeader(Response.Header); Response.HasContent := ParseResponseContent(Response); end; { Helpers } procedure HTTPParseRequest(var Request: THTTPRequest; const Buf; const BufSize: Integer); var P : THTTPParser; begin P := THTTPParser.Create; try P.SetTextBuf(Buf, BufSize); P.ParseRequest(Request); finally P.Free; end; end; procedure HTTPParseResponse(var Response: THTTPResponse; const Buf; const BufSize: Integer); var P : THTTPParser; begin P := THTTPParser.Create; try P.SetTextBuf(Buf, BufSize); P.ParseResponse(Response); finally P.Free; end; end; { THTTPContentDecoder } const SError_UnknownContentEncoding = 'Unknown content encoding'; SError_InvalidChunkedEncoding = 'Invalid chunked encoding'; constructor THTTPContentDecoder.Create( const ReadProc: THTTPContentDecoderReadProc; const ContentProc: THTTPContentDecoderContentProc; const CompleteProc: THTTPContentDecoderProc); begin Assert(Assigned(ReadProc)); Assert(Assigned(ContentProc)); Assert(Assigned(CompleteProc)); inherited Create; FReadProc := ReadProc; FContentProc := ContentProc; FCompleteProc := CompleteProc; Init; end; procedure THTTPContentDecoder.Init; begin end; destructor THTTPContentDecoder.Destroy; begin TCPBufferFinalise(FChunkBuf); inherited Destroy; end; procedure THTTPContentDecoder.Log(const LogMsg: String); begin if Assigned(FOnLog) then FOnLog(self, LogMsg); end; procedure THTTPContentDecoder.Log(const LogMsg: String; const LogArgs: array of const); begin Log(Format(LogMsg, LogArgs)); end; procedure THTTPContentDecoder.InitDecoder(const CommonHeaders: THTTPCommonHeaders); begin Log('Init'); if CommonHeaders.ContentLength.Value = hcltByteCount then begin FContentType := crctFixedSize; FContentSize := CommonHeaders.ContentLength.ByteCount; Log('ContentType:FixedSize:%db', [FContentSize]); if FContentSize = 0 then TriggerContentComplete; end else if CommonHeaders.TransferEncoding.Value = hteChunked then begin Log('ContentType:Chunked'); FContentType := crctChunked; FContentSize := -1; FChunkState := crcsChunkHeader; TCPBufferFinalise(FChunkBuf); TCPBufferInitialise(FChunkBuf, 65536, 256); end else if CommonHeaders.ContentType.Value <> hctNone then begin Log('ContentType:Unsized'); FContentType := crctUnsized; FContentSize := -1; end else raise EHTTP.Create(SError_UnknownContentEncoding); FContentReceived := 0; FContentComplete := False; end; procedure THTTPContentDecoder.TriggerContentBuffer(const Buf; const Size: Integer); begin {$IFDEF HTTP_DEBUG} Log('ContentBuffer:%db', [Size]); {$ENDIF} FContentProc(self, Buf, Size); end; procedure THTTPContentDecoder.TriggerContentComplete; begin {$IFDEF HTTP_DEBUG} Log('ContentComplete'); {$ENDIF} FContentComplete := True; FCompleteProc(self); end; procedure THTTPContentDecoder.TriggerTrailer(const Hdr: RawByteString); begin end; procedure THTTPContentDecoder.ProcessFixedSize; const ContentBlockSize = 65536; var Buf : array[0..ContentBlockSize - 1] of Byte; BufSize : Integer; GotContent : Boolean; ContentLeft : Int64; ContentSize : Integer; begin ContentLeft := FContentSize - FContentReceived; repeat BufSize := ContentBlockSize; if BufSize > ContentLeft then BufSize := ContentLeft; ContentSize := FReadProc(self, Buf[0], BufSize); GotContent := ContentSize > 0; if GotContent then begin Inc(FContentReceived, ContentSize); TriggerContentBuffer(Buf, ContentSize); Dec(ContentLeft, ContentSize); if ContentLeft <= 0 then begin TriggerContentComplete; break; end; end; until not GotContent; end; procedure THTTPContentDecoder.ProcessUnsized; const ContentBlockSize = 65536; var Buf : array[0..ContentBlockSize - 1] of Byte; GotContent : Boolean; ContentSize : Integer; begin repeat ContentSize := FReadProc(self, Buf[0], ContentBlockSize); GotContent := ContentSize > 0; if GotContent then begin Inc(FContentReceived, ContentSize); TriggerContentBuffer(Buf, ContentSize); end; until not GotContent; end; function THTTPContentDecoder.ProcessChunked_FillBuf(const Size: Integer): Boolean; var P : Pointer; L, N : Integer; begin L := TCPBufferUsed(FChunkBuf); {$IFDEF HTTP_DEBUG} Log('Chunk:FillBuf:BufferUsed:%db', [L]); {$ENDIF} Result := L >= Size; if Result then exit; N := Size - L; P := TCPBufferAddPtr(FChunkBuf, N); L := FReadProc(self, P^, N); {$IFDEF HTTP_DEBUG} Log('Chunk:FillBuf:Read:%db:%db', [N, L]); {$ENDIF} if L > 0 then begin Inc(FChunkBuf.Used, L); Result := L = N; end; end; function THTTPContentDecoder.ProcessChunked_FillBufBlock(const Size: Integer): Boolean; var P : Pointer; L : Integer; begin {$IFDEF HTTP_DEBUG} Log('Chunk:FillBufBlock:Size:%db', [Size]); {$ENDIF} P := TCPBufferAddPtr(FChunkBuf, Size); L := FReadProc(self, P^, Size); if L > 0 then begin {$IFDEF HTTP_DEBUG} Log('Chunk:FillBufBlock:Read:%db', [L]); {$ENDIF} Inc(FChunkBuf.Used, L); Result := True; end else Result := False; end; function THTTPContentDecoder.ProcessChunked_FillBufToCRLF(const BlockSize: Integer): Integer; var I : Integer; begin I := ProcessChunked_BufferCRLFPosition; if I < 0 then repeat if not ProcessChunked_FillBufBlock(BlockSize) then begin Result := -1; exit; end; I := ProcessChunked_BufferCRLFPosition; until I >= 0; Result := I; end; function THTTPContentDecoder.ProcessChunked_ReadStrToCRLF(const BlockSize: Integer; var Str: RawByteString): Boolean; var I : Integer; begin I := ProcessChunked_FillBufToCRLF(BlockSize); if I < 0 then begin Str := ''; Result := False; exit; end; SetLength(Str, I); if I > 0 then TCPBufferRemove(FChunkBuf, Str[1], I); TCPBufferDiscard(FChunkBuf, 2); {$IFDEF HTTP_DEBUG} Log('Chunk:ReadStrToCRLF:%s', [Str]); {$ENDIF} Result := True; end; function THTTPContentDecoder.ProcessChunked_ExpectCRLF: Boolean; var P : PByteChar; begin Result := ProcessChunked_FillBuf(2); if not Result then exit; P := TCPBufferPtr(FChunkBuf); if P^ <> #13 then raise EHTTP.Create(SError_InvalidChunkedEncoding); Inc(P); if P^ <> #10 then raise EHTTP.Create(SError_InvalidChunkedEncoding); TCPBufferDiscard(FChunkBuf, 2); Result := True; end; function THTTPContentDecoder.ProcessChunked_BufferCRLFPosition: Integer; var P : Pointer; A, B : PByte; L, I : Integer; begin L := TCPBufferPeekPtr(FChunkBuf, P); A := P; B := P; Inc(A); for I := 0 to L - 2 do if (B^ = 13) and (A^ = 10) then begin Result := I; exit; end else begin Inc(A); Inc(B); end; Result := -1; end; function THTTPContentDecoder.ProcessChunked_ReadHeader(var HdrStr: RawByteString; var ChunkSize: Int64): Boolean; const HeaderBlockSize = 256; var ParamPos : Integer; HdrValid : Boolean; Chunk32 : Word32; begin Result := ProcessChunked_ReadStrToCRLF(HeaderBlockSize, HdrStr); if not Result then exit; ParamPos := PosCharB(';', HdrStr); if ParamPos > 0 then SetLength(HdrStr, ParamPos - 1); HdrStr := StrTrimRightB(HdrStr); HdrValid := TryHexToWord32B(HdrStr, Chunk32); if not HdrValid then raise EHTTP.Create(SError_InvalidChunkedEncoding); ChunkSize := Chunk32; Result := True; end; function THTTPContentDecoder.ProcessChunked_Header: Boolean; var HdrStr : RawByteString; begin {$IFDEF HTTP_DEBUG} Log('Chunk:Header:BufferUsed:%db', [TCPBufferUsed(FChunkBuf)]); {$ENDIF} Result := ProcessChunked_ReadHeader(HdrStr, FChunkSize); if not Result then exit; FChunkProcessed := 0; if FChunkSize = 0 then begin FChunkState := crcsTrailer; exit; end; FChunkState := crcsContent; {$IFDEF HTTP_DEBUG} Log('Chunk:Header:State:Content:BufferUsed:%db:ChunkSize:%db', [TCPBufferUsed(FChunkBuf), FChunkSize]); {$ENDIF} end; function THTTPContentDecoder.ProcessChunked_Content: Boolean; const ContentBlockSize = 32768; var L : Integer; BufPtr : Pointer; ChunkLeft : Int64; begin ChunkLeft := FChunkSize - FChunkProcessed; repeat L := TCPBufferUsed(FChunkBuf); {$IFDEF HTTP_DEBUG} Log('Chunk:Content:BufferUsed:%db', [L]); {$ENDIF} if L > ChunkLeft then L := ChunkLeft; if L > 0 then begin TCPBufferPeekPtr(FChunkBuf, BufPtr); TriggerContentBuffer(BufPtr^, L); TCPBufferDiscard(FChunkBuf, L); Dec(ChunkLeft, L); Inc(FChunkProcessed, L); Inc(FContentReceived, L); if ChunkLeft = 0 then begin Result := True; FChunkState := crcsContentCRLF; {$IFDEF HTTP_DEBUG} Log('Chunk:Content:Complete'); {$ENDIF} exit; end; end; until not ProcessChunked_FillBufBlock(ContentBlockSize); {$IFDEF HTTP_DEBUG} Log('Chunk:Content:ExitProcess'); {$ENDIF} Result := False; end; function THTTPContentDecoder.ProcessChunked_ContentCRLF: Boolean; begin Result := ProcessChunked_ExpectCRLF; if not Result then exit; FChunkState := crcsChunkHeader; {$IFDEF HTTP_DEBUG} Log('Chunk:ContentCRLF'); {$ENDIF} end; function THTTPContentDecoder.ProcessChunked_Trailer: Boolean; const TrailerBlockSize = 512; var HdrStr : RawByteString; begin {$IFDEF HTTP_DEBUG} Log('Chunk:Trailer'); {$ENDIF} Result := True; while ProcessChunked_ReadStrToCRLF(TrailerBlockSize, HdrStr) do begin if HdrStr = '' then begin TriggerContentComplete; FChunkState := crcsFinished; ProcessChunked_Finalise; exit; end; TriggerTrailer(HdrStr); end; end; procedure THTTPContentDecoder.ProcessChunked_Finalise; begin {$IFDEF HTTP_DEBUG} Log('Chunk:Finalise'); {$ENDIF} TCPBufferFinalise(FChunkBuf); end; { Chunked-Body = *chunk last-chunk trailer CRLF chunk = chunk-size [ chunk-extension ] CRLF chunk-data CRLF chunk-size = 1*HEX last-chunk = 1*("0") [ chunk-extension ] CRLF chunk-extension= *( ";" chunk-ext-name [ "=" chunk-ext-val ] ) chunk-ext-name = token chunk-ext-val = token | quoted-string chunk-data = chunk-size(OCTET) trailer = *(entity-header CRLF) } procedure THTTPContentDecoder.ProcessChunked; var R : Boolean; begin repeat case FChunkState of crcsChunkHeader : R := ProcessChunked_Header; crcsContent : R := ProcessChunked_Content; crcsContentCRLF : R := ProcessChunked_ContentCRLF; crcsTrailer : R := ProcessChunked_Trailer; crcsFinished : R := False; else R := False; end; until not R; end; procedure THTTPContentDecoder.Process; begin {$IFDEF HTTP_DEBUG} Log('Process'); {$ENDIF} case FContentType of crctFixedSize : ProcessFixedSize; crctChunked : ProcessChunked; crctUnsized : ProcessUnsized; end; end; { THTTPContentReader } constructor THTTPContentReader.Create( const ReadProc: THTTPContentReaderReadProc; const ContentProc: THTTPContentReaderContentProc; const CompleteProc: THTTPContentReaderProc); begin Assert(Assigned(ReadProc)); Assert(Assigned(ContentProc)); Assert(Assigned(CompleteProc)); inherited Create; FReadProc := ReadProc; FContentProc := ContentProc; FCompleteProc := CompleteProc; Init; end; destructor THTTPContentReader.Destroy; begin FreeAndNil(FContentStringBuilder); FreeAndNil(FContentDecoder); inherited Destroy; end; procedure THTTPContentReader.Init; begin FContentDecoder := THTTPContentDecoder.Create( ContentDecoderReadProc, ContentDecoderContentProc, ContentDecoderCompleteProc); FContentDecoder.OnLog := ContentDecoderLog; end; procedure THTTPContentReader.Log(const LogMsg: String; const LogLevel: Integer); begin if Assigned(FOnLog) then FOnLog(self, LogMsg, LogLevel); end; procedure THTTPContentReader.Log(const LogMsg: String; const LogArgs: array of const; const LogLevel: Integer); begin Log(Format(LogMsg, LogArgs), LogLevel); end; procedure THTTPContentReader.ContentDecoderLog(const Sender: THTTPContentDecoder; const LogMsg: String); begin {$IFDEF HTTP_DEBUG} Log('Decoder:%s', [LogMsg], 1); {$ENDIF} end; function THTTPContentReader.ContentDecoderReadProc(const Sender: THTTPContentDecoder; var Buf; const Size: Integer): Integer; begin Result := FReadProc(self, Buf, Size); {$IFDEF HTTP_DEBUG} Log('Read:%db:%db', [Size, Result]); {$ENDIF} end; procedure THTTPContentReader.ContentDecoderContentProc(const Sender: THTTPContentDecoder; const Buf; const Size: Integer); begin {$IFDEF HTTP_DEBUG} Log('Content:%db', [Size]); {$ENDIF} FContentProc(self, Buf, Size); // Sender.ContentReceived case FMechanism of hcrmEvent : ; hcrmString : FContentStringBuilder.Append(@Buf, Size); hcrmStream : if Assigned(FContentStream) then FContentStream.WriteBuffer(Buf, Size); hcrmFile : if Assigned(FContentFile) then FContentFile.WriteBuffer(Buf, Size); end; end; procedure THTTPContentReader.ContentDecoderCompleteProc(const Sender: THTTPContentDecoder); begin {$IFDEF HTTP_DEBUG} Log('Complete'); {$ENDIF} case FMechanism of hcrmEvent : ; hcrmString : begin FContentString := FContentStringBuilder.AsRawByteString; FreeAndNil(FContentStringBuilder); end; hcrmStream : ; hcrmFile : FreeAndNil(FContentFile); end; FContentComplete := True; FCompleteProc(self); end; procedure THTTPContentReader.InitReader(const CommonHeaders: THTTPCommonHeaders); begin {$IFDEF HTTP_DEBUG} Log('InitReader:Mechanism=%d', [Ord(FMechanism)]); {$ENDIF} InternalReset; FContentDecoder.InitDecoder(CommonHeaders); case FMechanism of hcrmEvent : ; hcrmString : FContentStringBuilder := TRawByteStringBuilder.Create; hcrmStream : ; hcrmFile : if FContentFileName <> '' then FContentFile := TFileStream.Create(FContentFileName, fmCreate); end; end; procedure THTTPContentReader.Process; begin {$IFDEF HTTP_DEBUG} Log('Process'); {$ENDIF} FContentDecoder.Process; end; procedure THTTPContentReader.InternalReset; begin FContentString := ''; FreeAndNil(FContentStringBuilder); FreeAndNil(FContentFile); FContentComplete := False; end; procedure THTTPContentReader.Reset; begin InternalReset; end; function THTTPContentReader.GetContentReceivedSize: Int64; begin Result := FContentDecoder.ContentReceived; end; { THTTPContentWriter } constructor THTTPContentWriter.Create(const WriteProc: THTTPContentWriterWriteProc); begin Assert(Assigned(WriteProc)); inherited Create; FWriteProc := WriteProc; Init; end; procedure THTTPContentWriter.Init; begin end; destructor THTTPContentWriter.Destroy; begin inherited Destroy; end; procedure THTTPContentWriter.Log(const LogMsg: String); begin if Assigned(FOnLog) then FOnLog(self, LogMsg); end; procedure THTTPContentWriter.Log(const LogMsg: String; const Args: array of const); begin Log(Format(LogMsg, Args)); end; // Returns content length // Returns 0 if content specified and length is zero // Returns -1 if content not specified procedure THTTPContentWriter.InitContent(out HasContent: Boolean; out ContentLength: Int64); var R : Boolean; L : Int64; begin {$IFDEF HTTP_DEBUG} Log('InitContent:Mechanism=%d', [Ord(FMechanism)]); {$ENDIF} InternalReset; R := True; L := 0; case FMechanism of hctmNone : R := False; hctmEvent : raise EHTTP.Create('Mechanism not supported'); hctmString : L := Length(FContentString); hctmStream : if Assigned(FContentStream) then L := FContentStream.Size else R := False; hctmFile : if FContentFileName <> '' then begin FContentFile := TFileStream.Create(FContentFileName, fmOpenRead); L := FContentFile.Size; end else R := False; else raise EHTTP.Create('Mechanism not supported'); end; HasContent := R; ContentLength := L; FContentComplete := not R or (L = 0); {$IFDEF HTTP_DEBUG} Log('InitContent:ContentLength=%d', [ContentLength]); {$ENDIF} end; procedure THTTPContentWriter.WriteBuf(const Buf; const Size: Integer); begin if Size <= 0 then exit; Assert(Assigned(FWriteProc)); FWriteProc(self, Buf, Size); end; procedure THTTPContentWriter.WriteStr(const S: RawByteString); var L : Integer; begin L := Length(S); if L = 0 then exit; Assert(Assigned(FWriteProc)); FWriteProc(self, PByteChar(S)^, L); end; procedure THTTPContentWriter.SendContent; procedure SendContentFromStream(const S: TStream); const ContentBufSize = 32768; var ContentBuf : array[0..ContentBufSize - 1] of Byte; L : Integer; begin L := S.Read(ContentBuf[0], ContentBufSize); while L > 0 do begin WriteBuf(ContentBuf[0], L); L := S.Read(ContentBuf[0], ContentBufSize); end; FContentComplete := S.Position >= S.Size; end; begin case FMechanism of hctmNone : ; hctmEvent : ; hctmString : begin WriteStr(FContentString); FContentComplete := True; end; hctmStream : if Assigned(FContentStream) then SendContentFromStream(FContentStream); hctmFile : if Assigned(FContentFile) then SendContentFromStream(FContentFile); end; end; procedure THTTPContentWriter.FinaliseContent; begin {$IFDEF HTTP_DEBUG} Log('FinaliseContent', [Ord(FMechanism)]); {$ENDIF} case FMechanism of hctmNone : ; hctmEvent : ; hctmString : ; hctmStream : ; hctmFile : FreeAndNil(FContentFile); end; end; procedure THTTPContentWriter.InternalReset; begin FreeAndNil(FContentFile); end; procedure THTTPContentWriter.Reset; begin InternalReset; end; procedure THTTPContentWriter.Clear; begin FMechanism := hctmNone; FContentString := ''; FContentStream := nil; FContentFileName := ''; end; { } { Tests } { } {$IFDEF HTTP_TEST} {$ASSERTIONS ON} const // HTTP/1.1 TestReq1 = 'GET / HTTP/1.1'#13#10 + 'Host: www.example.com'#13#10 + 'Date: Mon 1 Jan 2010 12:23:34 GMT'#13#10 + 'Connection: close'#13#10 + 'Cookie: id=123'#13#10 + #13#10; // HTTP/1.0; Empty field values; Unknown field values; LWS TestReq2 = 'GET / HTTP/1.0'#13#10 + 'Host: abc'#13#10 + 'Date: '#13#10 + 'Connection: '#13#10' invalid'#13#10 + 'Cookie: invalid'#13#10 + #13#10; // Pre-HTTP/1.0 response; Incomplete request TestReq3 = 'GET /'#13#10 + 'Host: abc'#13#10 + 'X:'; // HTTP/1.1 TestResp1 = 'HTTP/1.1 200 OK'#13#10 + 'Server: Fundamentals'#13#10 + 'Date: Monday, 2 Jan 2010 12:23:34 GMT'#13#10 + 'Last-Modified: Monday, 2 Jan 2010 12:23:30 GMT'#13#10 + 'Content-Type: text/html; charset=iso123'#13#10 + 'Content-Length: 1'#13#10 + 'Content-Encoding: gzip'#13#10 + 'Age: 15'#13#10 + 'Connection: Keep-Alive'#13#10 + 'Set-Cookie: Domain=www.example.com; id=123'#13#10 + 'Set-Cookie: Domain=www.example.com; id=222'#13#10 + #13#10 + '1'; // HTTP/1.0; LWS; Empty field value; Custom field TestResp2 = 'HTTP/1.0 401 Bad'#13#10 + 'Server: '#13#10#9'Fundamentals'#13#10 + 'Content-Type: text/abc;'#13#10' charset=iso123'#13#10 + 'Content-Length: 1'#13#10 + 'Connection: '#13#10 + 'My-Field: abc'#13#10 + #13#10 + '1'; // HTTP/1.0; Incomplete response; Incorrect date value TestResp3 = 'HTTP/1.0 200 OK'#13#10 + 'Content-Length: 1'#13#10 + 'Date: 1 Jan 2001'#13#10 + 'X:'; procedure Test_Parser; var P : THTTPParser; S : RawByteString; R : THTTPRequest; T : THTTPResponse; begin InitHTTPRequest(R); InitHTTPResponse(T); P := THTTPParser.Create; try S := TestReq1; P.SetTextBuf(S[1], Length(S)); P.ParseRequest(R); Assert(R.HeaderComplete); Assert(R.StartLine.Method.Value = hmGET); Assert(R.StartLine.URI = '/'); Assert(R.StartLine.Version.Version = hvHTTP11); Assert(R.Header.FixedHeaders[hntHost] = 'www.example.com'); Assert(R.Header.CommonHeaders.Date.Value = hdParts); Assert(R.Header.CommonHeaders.Date.DayOfWeek = 2); Assert(Abs(R.Header.CommonHeaders.Date.DateTime - (EncodeDate(2010, 1, 1) + EncodeTime(12, 23, 34, 0))) < 1e-06); Assert(R.Header.CommonHeaders.Date.TimeZoneGMT); Assert(R.Header.CommonHeaders.Connection.Value = hcfClose); Assert(R.Header.Cookie.Value = hcoDecoded); Assert(Length(R.Header.Cookie.Entries) = 1); Assert(R.Header.Cookie.Entries[0].Name = 'id'); Assert(R.Header.Cookie.Entries[0].HasValue); Assert(R.Header.Cookie.Entries[0].Value = '123'); Assert(not R.HasContent); Assert(not HTTPMessageHasContent(T.Header.CommonHeaders)); ClearHTTPRequest(R); Assert(not R.HeaderComplete); Assert(R.StartLine.Method.Value = hmNone); Assert(R.StartLine.URI = ''); Assert(R.Header.CommonHeaders.Connection.Value = hcfNone); Assert(R.Header.CommonHeaders.ContentType.Value = hctNone); Assert(R.Header.FixedHeaders[hntHost] = ''); P.SetTextStr(TestReq2); P.ParseRequest(R); Assert(R.HeaderComplete); Assert(R.StartLine.Method.Value = hmGET); Assert(R.StartLine.URI = '/'); Assert(R.StartLine.Version.Version = hvHTTP10); Assert(R.Header.FixedHeaders[hntHost] = 'abc'); Assert(R.Header.CommonHeaders.Date.Custom = ''); Assert(R.Header.CommonHeaders.Connection.Value = hcfCustom); Assert(R.Header.CommonHeaders.Connection.Custom = 'invalid'); Assert(R.Header.Cookie.Value = hcoDecoded); Assert(Length(R.Header.Cookie.Entries) = 1); Assert(R.Header.Cookie.Entries[0].Name = 'invalid'); Assert(not R.Header.Cookie.Entries[0].HasValue); P.SetTextStr(TestReq3); P.ParseRequest(R); Assert(not R.HeaderComplete); Assert(R.StartLine.Method.Value = hmGET); Assert(R.StartLine.URI = '/'); Assert(R.StartLine.Version.Version = hvCustom); Assert(R.StartLine.Version.Protocol = hpCustom); Assert(R.StartLine.Version.CustomProtocol = ''); Assert(R.Header.FixedHeaders[hntHost] = 'abc'); S := TestResp1; P.SetTextBuf(S[1], Length(S)); P.ParseResponse(T); Assert(T.HeaderComplete); Assert(T.StartLine.Version.Version = hvHTTP11); Assert(T.StartLine.Code = 200); Assert(T.StartLine.Msg = hslmOK); Assert(T.Header.FixedHeaders[hntServer] = 'Fundamentals'); Assert(T.Header.CommonHeaders.ContentType.Value = hctTextHtml); Assert(Length(T.Header.CommonHeaders.ContentType.Parameters) = 1); Assert(T.Header.CommonHeaders.Date.DayOfWeek = 2); Assert(Abs(T.Header.CommonHeaders.Date.DateTime - (EncodeDate(2010, 1, 2) + EncodeTime(12, 23, 34, 0))) < 1e-06); Assert(T.Header.CommonHeaders.Date.TimeZoneGMT); Assert(T.Header.LastModified.Value = hdParts); Assert(Abs(T.Header.LastModified.DateTime - (EncodeDate(2010, 1, 2) + EncodeTime(12, 23, 30, 0))) < 1e-06); Assert(T.Header.CommonHeaders.ContentType.Parameters[0] = 'charset=iso123'); Assert(T.Header.CommonHeaders.ContentLength.Value = hcltByteCount); Assert(T.Header.CommonHeaders.ContentLength.ByteCount = 1); Assert(T.Header.CommonHeaders.Connection.Value = hcfKeepAlive); Assert(Length(T.Header.SetCookies) = 2); Assert(T.Header.SetCookies[0].Domain = 'www.example.com'); Assert(Length(T.Header.SetCookies[0].CustomFields) = 1); Assert(T.Header.SetCookies[0].CustomFields[0].Name = 'id'); Assert(T.Header.SetCookies[0].CustomFields[0].Value = '123'); Assert(T.Header.CommonHeaders.ContentEncoding.Value = hcefList); Assert(Length(T.Header.CommonHeaders.ContentEncoding.List) = 1); Assert(T.Header.CommonHeaders.ContentEncoding.List[0].Value = hceGzip); Assert(T.Header.Age.Value = hafAge); Assert(T.Header.Age.Age = 15); Assert(T.HasContent); Assert(HTTPMessageHasContent(T.Header.CommonHeaders)); ClearHTTPResponse(T); Assert(not T.HeaderComplete); Assert(T.StartLine.Version.Version = hvNone); Assert(T.StartLine.Msg = hslmNone); Assert(T.Header.FixedHeaders[hntServer] = ''); Assert(T.Header.CommonHeaders.Connection.Value = hcfNone); Assert(T.Header.CommonHeaders.ContentType.Value = hctNone); P.SetTextStr(TestResp2); P.ParseResponse(T); Assert(T.HeaderComplete); Assert(T.StartLine.Version.Version = hvHTTP10); Assert(T.StartLine.Code = 401); Assert(T.StartLine.CustomMsg = 'Bad'); Assert(T.Header.FixedHeaders[hntServer] = 'Fundamentals'); Assert(T.Header.CommonHeaders.ContentType.Value = hctTextCustom); Assert(T.Header.CommonHeaders.ContentType.CustomMinor = 'abc'); Assert(Length(T.Header.CommonHeaders.ContentType.Parameters) = 1); Assert(T.Header.CommonHeaders.ContentType.Parameters[0] = 'charset=iso123'); Assert(T.Header.CommonHeaders.ContentLength.Value = hcltByteCount); Assert(T.Header.CommonHeaders.ContentLength.ByteCount = 1); Assert(T.Header.CommonHeaders.Connection.Value = hcfCustom); Assert(T.Header.CommonHeaders.Connection.Custom = ''); Assert(T.Header.CommonHeaders.Date.Value = hdNone); Assert(Length(T.Header.CustomHeaders) = 1); Assert(T.Header.CustomHeaders[0].FieldName = 'My-Field'); Assert(T.Header.CustomHeaders[0].FieldValue = 'abc'); Assert(T.HasContent); Assert(HTTPMessageHasContent(T.Header.CommonHeaders)); ClearHTTPResponse(T); Assert(Length(T.Header.CustomHeaders) = 0); P.SetTextStr(TestResp3); P.ParseResponse(T); Assert(not T.HeaderComplete); Assert(T.StartLine.Version.Version = hvHTTP10); Assert(T.StartLine.Code = 200); Assert(T.StartLine.Msg = hslmOK); Assert(T.Header.CommonHeaders.ContentLength.Value = hcltByteCount); Assert(T.Header.CommonHeaders.ContentLength.ByteCount = 1); Assert(T.Header.CommonHeaders.Date.Value = hdCustom); Assert(T.Header.CommonHeaders.Date.Custom = '1 Jan 2001'); ClearHTTPRequest(R); R.StartLine.Method.Value := hmGET; R.StartLine.URI := '/'; R.StartLine.Version.Version := hvHTTP11; R.Header.CommonHeaders.Date.Value := hdDateTime; R.Header.CommonHeaders.Date.DateTime := GMTTimeToLocalTime(EncodeDate(2011, 6, 12) + EncodeTime(16, 15, 56, 0)); R.Header.FixedHeaders[hntHost] := 'abc'; R.Header.Cookie.Value := hcoDecoded; SetLength(R.Header.Cookie.Entries, 1); R.Header.Cookie.Entries[0].Name := 'id'; R.Header.Cookie.Entries[0].HasValue := True; R.Header.Cookie.Entries[0].Value := '123'; S := HTTPRequestToStr(R); Assert(S = 'GET / HTTP/1.1'#$D#$A + 'Date: Sun, 12 Jun 2011 16:15:56 GMT'#$D#$A + 'Host: abc'#$D#$A + 'Cookie: id=123'#$D#$A + #$D#$A); ClearHTTPResponse(T); T.StartLine.Version.Version := hvHTTP11; T.StartLine.Code := 200; T.StartLine.Msg := hslmOK; T.Header.CommonHeaders.Date.Value := hdDateTime; T.Header.CommonHeaders.Date.DateTime := GMTTimeToLocalTime(EncodeDate(2011, 6, 12) + EncodeTime(16, 15, 56, 0)); T.Header.FixedHeaders[hntServer] := 'abc'; S := HTTPResponseToStr(T); Assert(S = 'HTTP/1.1 200 OK'#$D#$A + 'Date: Sun, 12 Jun 2011 16:15:56 GMT'#$D#$A + 'Server: abc'#$D#$A + #$D#$A); finally P.Free; end; end; type THTTPContentReader_TestObj = class FBuf : RawByteString; FBufPos : Integer; FComplete : Boolean; FContent : RawByteString; procedure SetTestStr(const S: RawByteString); function ReaderRead(const Sender: THTTPContentDecoder; var Buf; const Size: Integer): Integer; procedure ReaderContentComplete(const Sender: THTTPContentDecoder); procedure ReaderContentBuf(const Sender: THTTPContentDecoder; const Buf; const Size: Integer); end; procedure THTTPContentReader_TestObj.SetTestStr(const S: RawByteString); begin FBuf := S; FBufPos := 0; FComplete := False; FContent := ''; end; function THTTPContentReader_TestObj.ReaderRead(const Sender: THTTPContentDecoder; var Buf; const Size: Integer): Integer; var L, N : Integer; begin L := Size; N := Length(FBuf) - FBufPos; if N < L then L := N; Move(FBuf[FBufPos + 1], Buf, L); Inc(FBufPos, L); Result := L; end; procedure THTTPContentReader_TestObj.ReaderContentBuf(const Sender: THTTPContentDecoder; const Buf; const Size: Integer); var L : Integer; begin L := Length(FContent); SetLength(FContent, L + Size); Move(Buf, FContent[L + 1], Size); end; procedure THTTPContentReader_TestObj.ReaderContentComplete(const Sender: THTTPContentDecoder); begin FComplete := True; end; const TestChunked1 = '5' + #13#10 + '12345' + #13#10 + '10 ;Test=1'#13#10 + '1234567890123456' + #13#10 + '0'#13#10 + 'Footer1: 123' + #13#10 + 'Footer2: 456' + #13#10 + #13#10; TestChunked2 = '0' + #13#10 + #13#10; TestStr512 = '1234567890123456789012345678901234567890123456789012345678901234' + '1234567890123456789012345678901234567890123456789012345678901234' + '1234567890123456789012345678901234567890123456789012345678901234' + '1234567890123456789012345678901234567890123456789012345678901234' + '1234567890123456789012345678901234567890123456789012345678901234' + '1234567890123456789012345678901234567890123456789012345678901234' + '1234567890123456789012345678901234567890123456789012345678901234' + '1234567890123456789012345678901234567890123456789012345678901234'; TestChunked3 = '200' + #13#10 + TestStr512 + #13#10 + '200' + #13#10 + TestStr512 + #13#10 + '1' + #13#10 + 'X' + #13#10 + '0' + #13#10 + #13#10; procedure Test_Reader; var T : THTTPContentReader_TestObj; R : THTTPContentDecoder; H : THTTPCommonHeaders; begin T := THTTPContentReader_TestObj.Create; R := THTTPContentDecoder.Create(T.ReaderRead, T.ReaderContentBuf, T.ReaderContentComplete); try FillChar(H, SizeOf(H), 0); H.TransferEncoding.Value := hteChunked; R.InitDecoder(H); T.SetTestStr(TestChunked1); repeat R.Process; until T.FComplete; Assert(T.FBufPos >= Length(T.FBuf)); Assert(T.FContent = '123451234567890123456'); Assert(R.ContentReceived = 21); R.InitDecoder(H); T.SetTestStr(TestChunked2); repeat R.Process; until T.FComplete; Assert(T.FBufPos >= Length(T.FBuf)); Assert(T.FContent = ''); Assert(R.ContentReceived = 0); R.InitDecoder(H); T.SetTestStr(TestChunked3); repeat R.Process; until T.FComplete; Assert(T.FBufPos >= Length(T.FBuf)); Assert(T.FContent = TestStr512 + TestStr512 + 'X'); Assert(R.ContentReceived = 1025); finally R.Free; T.Free; end; end; procedure Test; begin Test_Parser; Test_Reader; end; {$ENDIF} end.