{******************************************************************************} { } { Library: Fundamentals 5.00 } { File name: flcHTTPClient.pas } { File version: 5.12 } { Description: HTTP client. } { } { Copyright: Copyright (c) 2009-2018, 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: } { } { 2009/09/03 0.01 Initial development. } { 2011/06/12 0.02 Further development. } { 2011/06/14 0.03 HTTPS support. } { 2011/06/17 0.04 Cookies. } { 2011/06/18 0.05 Multiple requests on same connection. } { 2011/06/19 0.06 Response content mechanisms. } { 2011/07/31 0.07 Connection close support. } { 2011/10/06 4.08 SynchronisedEvents option. } { 2013/03/23 4.09 CustomHeader property. } { 2013/03/24 4.10 SetRequestContentWwwFormUrlEncodedField method. } { 2015/05/05 4.11 RawByteString changes. } { 2016/01/09 5.12 Revised for Fundamentals 5. } { } {******************************************************************************} {$INCLUDE flcHTTP.inc} unit flcHTTPClient; interface uses { System } {$IFDEF MSWIN} Windows, {$ENDIF} SysUtils, Classes, SyncObjs, { Fundamentals } flcStdTypes, flcStrings, { Fundamentals TCP } flcTCPConnection, flcTCPClient, { Fundamentals HTTP } flcHTTPUtils; { } { HTTP Client } { } type THTTPClientLogType = ( cltDebug, cltInfo, cltError); THTTPClientAddressFamily = ( cafIP4, cafIP6); THTTPClientMethod = ( cmGET, cmPOST, cmCustom); THTTPKeepAliveOption = ( kaDefault, kaKeepAlive, kaClose); {$IFDEF HTTP_TLS} THTTPSClientOption = ( csoDontUseSSL3, csoDontUseTLS10, csoDontUseTLS11, csoDontUseTLS12); THTTPSClientOptions = set of THTTPSClientOption; {$ENDIF} TF5HTTPClientState = ( hcsInit, hcsStarting, hcsStopping, hcsStopped, hcsConnectFailed, hcsConnected_Ready, hcsSendingRequest, hcsSendingContent, hcsAwaitingResponse, hcsReceivedResponse, hcsReceivingContent, hcsResponseComplete, hcsResponseCompleteAndClosing, hcsResponseCompleteAndClosed, hcsRequestInterruptedAndClosed, hcsRequestFailed); TF5HTTPClient = class; TSyncProc = procedure of object; THTTPClientEvent = procedure (Client: TF5HTTPClient) of object; THTTPClientLogEvent = procedure (Client: TF5HTTPClient; LogType: THTTPClientLogType; Msg: String; Level: Integer) of object; THTTPClientStateEvent = procedure (Client: TF5HTTPClient; State: TF5HTTPClientState) of object; THTTPClientContentEvent = procedure (Client: TF5HTTPClient; const Buf; const Size: Integer) of object; TF5HTTPClient = class(TComponent) protected FSynchronisedEvents : Boolean; // event handlers FOnLog : THTTPClientLogEvent; FOnStateChange : THTTPClientStateEvent; FOnStart : THTTPClientEvent; FOnStop : THTTPClientEvent; FOnActive : THTTPClientEvent; FOnInactive : THTTPClientEvent; FOnResponseHeader : THTTPClientEvent; FOnResponseContentBuffer : THTTPClientContentEvent; FOnResponseContentComplete : THTTPClientEvent; FOnResponseComplete : THTTPClientEvent; FOnThreadWait : THTTPClientEvent; FOnMainThreadWait : THTTPClientEvent; // host FAddressFamily : THTTPClientAddressFamily; FHost : String; FPort : String; // https {$IFDEF HTTP_TLS} FUseHTTPS : Boolean; FHTTPSOptions : THTTPSClientOptions; {$ENDIF} // http proxy FUseHTTPProxy : Boolean; FHTTPProxyHost : String; FHTTPProxyPort : String; // http request FMethod : THTTPClientMethod; FMethodCustom : RawByteString; FURI : RawByteString; FUserAgent : RawByteString; FKeepAlive : THTTPKeepAliveOption; FReferer : RawByteString; FCookie : RawByteString; FAuthorization : RawByteString; FCustomHeaders : THTTPCustomHeaders; // request content parameters FRequestContentType : RawByteString; FRequestContentWriter : THTTPContentWriter; // other parameters FUserObject : TObject; FUserData : Pointer; FUserTag : NativeInt; // state FLock : TCriticalSection; FState : TF5HTTPClientState; FErrorMsg : String; FActive : Boolean; FActivateOnLoaded : Boolean; FViaHTTPProxy : Boolean; FTCPClient : TF5TCPClient; FHTTPParser : THTTPParser; FInRequest : Boolean; FInDoStart : Boolean; FInDoStop : Boolean; FRequestPending : Boolean; FRequest : THTTPRequest; FRequestHasContent : Boolean; FResponse : THTTPResponse; FResponseCode : Integer; FResponseCookies : TStrings; FResponseContentReader : THTTPContentReader; FResponseRequireClose : Boolean; FResponseContentBufPtr : Pointer; FResponseContentBufSize : Integer; FSyncLogType : THTTPClientLogType; FSyncLogMsg : String; FSyncLogLevel : Integer; procedure Init; virtual; procedure InitDefaults; virtual; procedure Loaded; override; procedure Synchronize(const SyncProc: TSyncProc); procedure SyncLog; procedure Log(const LogType: THTTPClientLogType; const Msg: String; const Level: Integer = 0); overload; procedure Log(const LogType: THTTPClientLogType; const Msg: String; const Args: array of const; const Level: Integer = 0); overload; procedure Lock; procedure Unlock; function GetState: TF5HTTPClientState; function GetStateStr: String; procedure SetState(const State: TF5HTTPClientState); procedure CheckNotActive; function IsBusyStarting: Boolean; function IsBusyWithRequest: Boolean; procedure CheckNotBusyWithRequest; procedure SetSynchronisedEvents(const SynchronisedEvents: Boolean); procedure SetAddressFamily(const AddressFamily: THTTPClientAddressFamily); procedure SetHost(const Host: String); procedure SetPort(const Port: String); function GetPortInt: Integer; procedure SetPortInt(const PortInt: Integer); {$IFDEF HTTP_TLS} procedure SetUseHTTPS(const UseHTTPS: Boolean); procedure SetHTTPSOptions(const HTTPSOptions: THTTPSClientOptions); {$ENDIF} procedure SetUseHTTPProxy(const UseHTTPProxy: Boolean); procedure SetHTTPProxyHost(const HTTPProxyHost: String); procedure SetHTTPProxyPort(const HTTPProxyPort: String); procedure SetMethod(const Method: THTTPClientMethod); procedure SetMethodCustom(const MethodCustom: RawByteString); procedure SetURI(const URI: RawByteString); procedure SetUserAgent(const UserAgent: RawByteString); procedure SetKeepAlive(const KeepAlive: THTTPKeepAliveOption); procedure SetReferer(const Referer: RawByteString); procedure SetAuthorization(const Authorization: RawByteString); function GetCustomHeaderByName(const FieldName: RawByteString): PHTTPCustomHeader; function AddCustomHeader(const FieldName: RawByteString): PHTTPCustomHeader; function GetCustomHeader(const FieldName: RawByteString): RawByteString; procedure SetCustomHeader(const FieldName: RawByteString; const FieldValue: RawByteString); procedure SetRequestContentType(const RequestContentType: RawByteString); function GetRequestContentMechanism: THTTPContentWriterMechanism; procedure SetRequestContentMechanism(const RequestContentMechanism: THTTPContentWriterMechanism); function GetRequestContentStr: RawByteString; procedure SetRequestContentStr(const RequestContentStr: RawByteString); function GetRequestContentStream: TStream; procedure SetRequestContentStream(const RequestContentStream: TStream); function GetRequestContentFileName: String; procedure SetRequestContentFileName(const RequestContentFileName: String); function GetResponseContentMechanism: THTTPContentReaderMechanism; procedure SetResponseContentMechanism(const ResponseContentMechanism: THTTPContentReaderMechanism); function GetResponseContentFileName: String; procedure SetResponseContentFileName(const ResponseContentFileName: String); function GetResponseContentStream: TStream; procedure SetResponseContentStream(const ResponseContentStream: TStream); procedure SyncTriggerStateChanged; procedure SyncTriggerStart; procedure SyncTriggerStop; procedure SyncTriggerActive; procedure SyncTriggerInactive; procedure SyncTriggerResponseHeader; procedure SyncTriggerResponseContentBuffer; procedure SyncTriggerResponseContentComplete; procedure SyncTriggerResponseComplete; procedure TriggerStateChanged; procedure TriggerStart; procedure TriggerStop; procedure TriggerActive; procedure TriggerInactive; procedure TriggerResponseHeader; procedure TriggerResponseContentBuffer(const Buf; const BufSize: Integer); procedure TriggerResponseContentComplete; procedure TriggerResponseComplete; procedure ProcessResponseHeader; procedure SetResponseComplete; procedure SetResponseCompleteThenClosed; procedure InitTCPClientHost; procedure InitTCPClient; procedure TCPClientLog(Client: TF5TCPClient; LogType: TTCPClientLogType; Msg: String; LogLevel: Integer); procedure TCPClientIdle(Client: TF5TCPClient); procedure TCPClientStateChanged(Client: TF5TCPClient; State: TTCPClientState); procedure TCPClientError(Client: TF5TCPClient; ErrorMsg: String; ErrorCode: Integer); procedure TCPClientConnected(Client: TF5TCPClient); procedure TCPClientConnectFailed(Client: TF5TCPClient); procedure TCPClientReady(Client: TF5TCPClient); procedure TCPClientRead(Client: TF5TCPClient); procedure TCPClientWrite(Client: TF5TCPClient); procedure TCPClientClose(Client: TF5TCPClient); procedure TCPClientMainThreadWait(Client: TF5TCPClient); procedure TCPClientThreadWait(Client: TF5TCPClient); procedure ResetRequest; procedure SetErrorMsg(const ErrorMsg: String); procedure SetRequestFailedFromException(const E: Exception); function InitRequestContent(out HasContent: Boolean): Int64; procedure FinaliseRequestContent; procedure PrepareHTTPRequest; function GetHTTPRequestStr: RawByteString; procedure SendStr(const S: RawByteString); procedure SendRequest; procedure InitResponseContent; procedure HandleResponseContent(const Buf; const Size: Integer); procedure FinaliseResponseContent(const Success: Boolean); procedure ContentWriterLog(const Sender: THTTPContentWriter; const LogMsg: String); function ContentWriterWriteProc(const Sender: THTTPContentWriter; const Buf; const Size: Integer): Integer; procedure ContentReaderLog(const Sender: THTTPContentReader; const LogMsg: String; const LogLevel: Integer); function ContentReaderReadProc(const Sender: THTTPContentReader; var Buf; const Size: Integer): Integer; procedure ContentReaderContentProc(const Sender: THTTPContentReader; const Buf; const Size: Integer); procedure ContentReaderCompleteProc(const Sender: THTTPContentReader); procedure ReadResponseHeader; procedure ReadResponseContent; procedure ReadResponse; procedure DoStartTCPClient; procedure DoStart; procedure DoStopTCPClient; procedure DoStop; procedure SetActive(const Active: Boolean); function GetResponseContentStr: RawByteString; procedure Wait; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; // When SynchronisedEvents is set, events handlers are called in the main thread // through the TThread.Synchronise mechanism. If not set, events handlers may // be called from any thread. In this case event handler should handle their // own synchronisation if required. property SynchronisedEvents: Boolean read FSynchronisedEvents write SetSynchronisedEvents default False; property OnLog: THTTPClientLogEvent read FOnLog write FOnLog; property OnStateChange: THTTPClientStateEvent read FOnStateChange write FOnStateChange; property OnStart: THTTPClientEvent read FOnStart write FOnStart; property OnStop: THTTPClientEvent read FOnStop write FOnStop; property OnActive: THTTPClientEvent read FOnActive write FOnActive; property OnInactive: THTTPClientEvent read FOnInactive write FOnInactive; property OnResponseHeader: THTTPClientEvent read FOnResponseHeader write FOnResponseHeader; property OnResponseContentBuffer: THTTPClientContentEvent read FOnResponseContentBuffer write FOnResponseContentBuffer; property OnResponseContentComplete: THTTPClientEvent read FOnResponseContentComplete write FOnResponseContentComplete; property OnResponseComplete: THTTPClientEvent read FOnResponseComplete write FOnResponseComplete; property AddressFamily: THTTPClientAddressFamily read FAddressFamily write SetAddressFamily default cafIP4; property Host: String read FHost write SetHost; property Port: String read FPort write SetPort; property PortInt: Integer read GetPortInt write SetPortInt; {$IFDEF HTTP_TLS} property UseHTTPS: Boolean read FUseHTTPS write SetUseHTTPS default False; property HTTPSOptions: THTTPSClientOptions read FHTTPSOptions write SetHTTPSOptions default []; {$ENDIF} property UseHTTPProxy: Boolean read FUseHTTPProxy write SetUseHTTPProxy default False; property HTTPProxyHost: String read FHTTPProxyHost write SetHTTPProxyHost; property HTTPProxyPort: String read FHTTPProxyPort write SetHTTPProxyPort; property Method: THTTPClientMethod read FMethod write SetMethod default cmGET; property MethodCustom: RawByteString read FMethodCustom write SetMethodCustom; property URI: RawByteString read FURI write SetURI; property UserAgent: RawByteString read FUserAgent write SetUserAgent; property KeepAlive: THTTPKeepAliveOption read FKeepAlive write SetKeepAlive default kaDefault; property Referer: RawByteString read FReferer write SetReferer; property Cookie: RawByteString read FCookie write FCookie; property Authorization: RawByteString read FAuthorization write SetAuthorization; procedure SetBasicAuthorization(const Username, Password: RawByteString); property CustomHeader[const FieldName: RawByteString]: RawByteString read GetCustomHeader write SetCustomHeader; property RequestContentType: RawByteString read FRequestContentType write SetRequestContentType; property RequestContentMechanism: THTTPContentWriterMechanism read GetRequestContentMechanism write SetRequestContentMechanism default hctmString; property RequestContentStr: RawByteString read GetRequestContentStr write SetRequestContentStr; property RequestContentStream: TStream read GetRequestContentStream write SetRequestContentStream; property RequestContentFileName: String read GetRequestContentFileName write SetRequestContentFileName; procedure SetRequestContentWwwFormUrlEncodedField(const FieldName, FieldValue: RawByteString); property ResponseContentMechanism: THTTPContentReaderMechanism read GetResponseContentMechanism write SetResponseContentMechanism default hcrmEvent; property ResponseContentFileName: String read GetResponseContentFileName write SetResponseContentFileName; property ResponseContentStream: TStream read GetResponseContentStream write SetResponseContentStream; property State: TF5HTTPClientState read GetState; property StateStr: String read GetStateStr; property Active: Boolean read FActive write SetActive default False; procedure Request; function RequestIsBusy: Boolean; function RequestIsSuccess: Boolean; property ErrorMsg: String read FErrorMsg; property ResponseRecord: THTTPResponse read FResponse; property ResponseCode: Integer read FResponseCode; property ResponseCookies: TStrings read FResponseCookies; property ResponseContentStr: RawByteString read GetResponseContentStr; property UserObject: TObject read FUserObject write FUserObject; property UserData: Pointer read FUserData write FUserData; property UserTag: NativeInt read FUserTag write FUserTag; // Blocking helpers // These functions will block until a result is available or timeout expires. // When blocking occurs in the main thread, OnMainThreadWait is called. // When blocking occurs in another thread, OnThreadWait is called. // Usually the handler for OnMainThreadWait calls Application.ProcessMessages. // Note: // These functions should not be called from this object's event handlers. function WaitForConnect(const Timeout: Integer): Boolean; function WaitRequestNotBusy(const Timeout: Integer): Boolean; property OnThreadWait: THTTPClientEvent read FOnThreadWait write FOnThreadWait; property OnMainThreadWait: THTTPClientEvent read FOnMainThreadWait write FOnMainThreadWait; end; EHTTPClient = class(Exception); { } { HTTP Client Collection } { } type THTTPClientCollection = class private FItemOwner : Boolean; FList : array of TF5HTTPClient; function GetCount: Integer; function GetItem(const Idx: Integer): TF5HTTPClient; protected function CreateNew: TF5HTTPClient; virtual; public constructor Create(const ItemOwner: Boolean); destructor Destroy; override; property ItemOwner: Boolean read FItemOwner; property Count: Integer read GetCount; property Item[const Idx: Integer]: TF5HTTPClient read GetItem; default; function Add(const Item: TF5HTTPClient): Integer; function AddNew: TF5HTTPClient; function GetItemIndex(const Item: TF5HTTPClient): Integer; procedure RemoveByIndex(const Idx: Integer); function Remove(const Item: TF5HTTPClient): Boolean; procedure Clear; end; EHTTPClientCollection = class(Exception); { } { Component } { } type TfclHTTPClient = class(TF5HTTPClient) published property SynchronisedEvents; property OnLog; property OnStateChange; property OnStart; property OnStop; property OnActive; property OnInactive; property OnResponseHeader; property OnResponseContentBuffer; property OnResponseContentComplete; property OnResponseComplete; property AddressFamily; property Host; property Port; property PortInt; {$IFDEF HTTP_TLS} property UseHTTPS; property HTTPSOptions; {$ENDIF} property UseHTTPProxy; property HTTPProxyHost; property HTTPProxyPort; property Method; property MethodCustom; property URI; property UserAgent; property KeepAlive; property Referer; property Cookie; property Authorization; property RequestContentType; property RequestContentMechanism; property RequestContentStr; property RequestContentFileName; property ResponseContentMechanism; property ResponseContentFileName; property Active; end; {$IFDEF HTTPCLIENT_CUSTOM} {$INCLUDE cHTTPClientIntf.inc} {$ENDIF} implementation uses {$IFDEF HTTPCLIENT_CUSTOM} {$INCLUDE cHTTPClientUses.inc} {$ENDIF} { Fundamentals } flcBase64, flcStringBuilder, flcDateTime, flcSocketLib, {$IFDEF HTTP_TLS} flcTLSTransportClient, {$ENDIF} flcTCPUtils; { } { HTTP Client constants } { } const HTTPCLIENT_PORT = 80; HTTPCLIENT_PORT_STR = '80'; HTTPCLIENT_METHOD_GET = 'GET'; HTTPCLIENT_METHOD_POST = 'POST'; HTTPCLIENT_ResponseHeader_MaxSize = 16384; HTTPCLIENT_ResponseHeader_Delim = #13#10#13#10; HTTPCLIENT_ResponseHeader_DelimLen = Length(HTTPCLIENT_ResponseHeader_Delim); HTTPCLIENT_UserAgent = 'Mozilla/5.0 (compatible; Fundamentals/4.0)'; HTTP4ClientState_All = [ hcsInit, hcsStarting, hcsStopping, hcsStopped, hcsConnectFailed, hcsConnected_Ready, hcsSendingRequest, hcsSendingContent, hcsAwaitingResponse, hcsReceivedResponse, hcsReceivingContent, hcsResponseComplete, hcsResponseCompleteAndClosing, hcsResponseCompleteAndClosed, hcsRequestInterruptedAndClosed, hcsRequestFailed ]; HTTP4ClientState_BusyWithRequest = [ hcsSendingRequest, hcsSendingContent, hcsAwaitingResponse, hcsReceivedResponse, hcsReceivingContent ]; HTTP4ClientState_Closed = [ hcsInit, hcsStopped, hcsConnectFailed, hcsResponseCompleteAndClosed, hcsRequestInterruptedAndClosed ]; HTTPClientState_ResponseComplete = [ hcsResponseComplete, hcsResponseCompleteAndClosing, hcsResponseCompleteAndClosed ]; { } { Errors and debug strings } { } const SError_NotAllowedWhileActive = 'Operation not allowed while active'; SError_NotAllowedWhileBusyWithRequest = 'Operation not allowed while busy with request'; SError_MethodNotSet = 'Method not set'; SError_URINotSet = 'URI not set'; SError_HostNotSet = 'Host not set'; SError_InvalidParameter = 'Invalid parameter'; SClientState : array[TF5HTTPClientState] of String = ( 'Initialise', 'Starting', 'Stopping', 'Stopped', 'ConnectFailed', 'Connected', 'SendingRequest', 'SendingContent', 'AwaitingResponse', 'ReceivedResponse', 'ReceivingContent', 'ResponseComplete', 'ResponseCompleteAndClosing', 'ResponseCompleteAndClosed', 'RequestInterruptedAndClosed', 'RequestFailed' ); { } { THTTPClient } { } constructor TF5HTTPClient.Create(AOwner: TComponent); begin inherited Create(AOwner); Init; end; procedure TF5HTTPClient.Init; begin FLock := TCriticalSection.Create; FResponseCookies := TStringList.Create; FHTTPParser := THTTPParser.Create; FRequestContentWriter := THTTPContentWriter.Create( ContentWriterWriteProc); FRequestContentWriter.OnLog := ContentWriterLog; FResponseContentReader := THTTPContentReader.Create( ContentReaderReadProc, ContentReaderContentProc, ContentReaderCompleteProc); FResponseContentReader.OnLog := ContentReaderLog; FState := hcsInit; FActivateOnLoaded := False; InitHTTPRequest(FRequest); InitHTTPResponse(FResponse); InitDefaults; end; procedure TF5HTTPClient.InitDefaults; begin FSynchronisedEvents := False; FMethod := cmGET; FPort := HTTPCLIENT_PORT_STR; {$IFDEF HTTP_TLS} FUseHTTPS := False; FHTTPSOptions := []; {$ENDIF} FUseHTTPProxy := False; FUserAgent := HTTPCLIENT_UserAgent; FRequestContentWriter.Mechanism := hctmString; FResponseContentReader.Mechanism := hcrmEvent; FUserObject := nil; FUserData := nil; FUserTag := 0; end; destructor TF5HTTPClient.Destroy; begin if Assigned(FTCPClient) then begin FTCPClient.Finalise; FreeAndNil(FTCPClient); end; FreeAndNil(FRequestContentWriter); FreeAndNil(FResponseContentReader); FreeAndNil(FHTTPParser); FreeAndNil(FResponseCookies); FreeAndNil(FLock); inherited Destroy; end; procedure TF5HTTPClient.Loaded; begin inherited Loaded; if FActivateOnLoaded then DoStart; end; procedure TF5HTTPClient.Synchronize(const SyncProc: TSyncProc); begin {$IFDEF DELPHI6_DOWN} if GetCurrentThreadID = MainThreadID then SyncProc; {$ELSE} TThread.Synchronize(nil, SyncProc); {$ENDIF} end; procedure TF5HTTPClient.SyncLog; begin if csDestroying in ComponentState then exit; if Assigned(FOnLog) then FOnLog(self, FSyncLogType, FSyncLogMsg, FSyncLogLevel); end; procedure TF5HTTPClient.Log(const LogType: THTTPClientLogType; const Msg: String; const Level: Integer); begin if Assigned(FOnLog) then if FSynchronisedEvents {$IFDEF MSWIN} and (GetCurrentThreadID <> MainThreadID) {$ENDIF} then begin FSyncLogType := LogType; FSyncLogMsg := Msg; FSyncLogLevel := Level; Synchronize(SyncLog); end else FOnLog(self, LogType, Msg, Level); end; procedure TF5HTTPClient.Log(const LogType: THTTPClientLogType; const Msg: String; const Args: array of const; const Level: Integer); begin Log(LogType, Format(Msg, Args), Level); end; procedure TF5HTTPClient.Lock; begin if Assigned(FLock) then FLock.Acquire; end; procedure TF5HTTPClient.Unlock; begin if Assigned(FLock) then FLock.Release; end; function TF5HTTPClient.GetState: TF5HTTPClientState; begin Lock; try Result := FState; finally Unlock; end; end; function TF5HTTPClient.GetStateStr: String; begin Result := SClientState[GetState]; end; procedure TF5HTTPClient.SetState(const State: TF5HTTPClientState); begin Lock; try Assert(State <> FState); FState := State; finally Unlock; end; TriggerStateChanged; end; procedure TF5HTTPClient.CheckNotActive; begin if not (csDesigning in ComponentState) then if FActive then raise EHTTPClient.Create(SError_NotAllowedWhileActive); end; function TF5HTTPClient.IsBusyStarting: Boolean; begin Result := (FState = hcsStarting); end; function TF5HTTPClient.IsBusyWithRequest: Boolean; begin Result := False; if FActive then if FState in HTTP4ClientState_BusyWithRequest then Result := True else if FRequestPending and (FState in [hcsStarting, hcsConnected_Ready]) then Result := True; end; procedure TF5HTTPClient.CheckNotBusyWithRequest; begin if not (csDesigning in ComponentState) and not (csLoading in ComponentState) then begin Lock; try if IsBusyWithRequest then raise EHTTPClient.Create(SError_NotAllowedWhileBusyWithRequest); finally Unlock; end; end; end; procedure TF5HTTPClient.SetSynchronisedEvents(const SynchronisedEvents: Boolean); begin if SynchronisedEvents = FSynchronisedEvents then exit; CheckNotActive; FSynchronisedEvents := SynchronisedEvents; end; procedure TF5HTTPClient.SetAddressFamily(const AddressFamily: THTTPClientAddressFamily); begin if AddressFamily = FAddressFamily then exit; CheckNotBusyWithRequest; FAddressFamily := AddressFamily; end; procedure TF5HTTPClient.SetHost(const Host: String); begin if Host = FHost then exit; CheckNotBusyWithRequest; FHost := Host; end; procedure TF5HTTPClient.SetPort(const Port: String); begin if Port = FPort then exit; CheckNotBusyWithRequest; FPort := Port; end; function TF5HTTPClient.GetPortInt: Integer; begin Result := StrToIntDef(FPort, -1); end; procedure TF5HTTPClient.SetPortInt(const PortInt: Integer); begin if (PortInt <= 0) or (PortInt >= $FFFF) then raise EHTTPClient.Create(SError_InvalidParameter); SetPort(IntToStr(PortInt)); end; {$IFDEF HTTP_TLS} procedure TF5HTTPClient.SetUseHTTPS(const UseHTTPS: Boolean); begin if UseHTTPS = FUseHTTPS then exit; CheckNotBusyWithRequest; FUseHTTPS := UseHTTPS; end; procedure TF5HTTPClient.SetHTTPSOptions(const HTTPSOptions: THTTPSClientOptions); begin if HTTPSOptions = FHTTPSOptions then exit; CheckNotBusyWithRequest; FHTTPSOptions := HTTPSOptions; end; {$ENDIF} procedure TF5HTTPClient.SetUseHTTPProxy(const UseHTTPProxy: Boolean); begin if UseHTTPProxy = FUseHTTPProxy then exit; CheckNotBusyWithRequest; FUseHTTPProxy := UseHTTPProxy; end; procedure TF5HTTPClient.SetHTTPProxyHost(const HTTPProxyHost: String); begin if HTTPProxyHost = FHTTPProxyHost then exit; CheckNotBusyWithRequest; FHTTPProxyHost := HTTPProxyHost; end; procedure TF5HTTPClient.SetHTTPProxyPort(const HTTPProxyPort: String); begin if HTTPProxyPort = FHTTPProxyPort then exit; CheckNotBusyWithRequest; FHTTPProxyPort := HTTPProxyPort; end; procedure TF5HTTPClient.SetMethod(const Method: THTTPClientMethod); begin if Method = FMethod then exit; CheckNotBusyWithRequest; FMethod := Method; end; procedure TF5HTTPClient.SetMethodCustom(const MethodCustom: RawByteString); begin if MethodCustom = FMethodCustom then exit; CheckNotBusyWithRequest; FMethodCustom := MethodCustom; end; procedure TF5HTTPClient.SetURI(const URI: RawByteString); begin if URI = FURI then exit; CheckNotBusyWithRequest; FURI := URI; end; procedure TF5HTTPClient.SetUserAgent(const UserAgent: RawByteString); begin if UserAgent = FUserAgent then exit; CheckNotBusyWithRequest; FUserAgent := UserAgent; end; procedure TF5HTTPClient.SetKeepAlive(const KeepAlive: THTTPKeepAliveOption); begin if KeepAlive = FKeepAlive then exit; CheckNotBusyWithRequest; FKeepAlive := KeepAlive; end; procedure TF5HTTPClient.SetReferer(const Referer: RawByteString); begin if Referer = FReferer then exit; CheckNotBusyWithRequest; FReferer := Referer; end; procedure TF5HTTPClient.SetAuthorization(const Authorization: RawByteString); begin if Authorization = FAuthorization then exit; CheckNotBusyWithRequest; FAuthorization := Authorization; end; procedure TF5HTTPClient.SetBasicAuthorization(const Username, Password: RawByteString); begin SetAuthorization('Basic ' + MIMEBase64Encode(Username + ':' + Password)); end; function TF5HTTPClient.GetCustomHeaderByName(const FieldName: RawByteString): PHTTPCustomHeader; begin Result := HTTPCustomHeadersGetByName(FCustomHeaders, FieldName); end; function TF5HTTPClient.AddCustomHeader(const FieldName: RawByteString): PHTTPCustomHeader; var P : PHTTPCustomHeader; begin Assert(FieldName <> ''); P := HTTPCustomHeadersAdd(FCustomHeaders); P^.FieldName := FieldName; Result := P; end; function TF5HTTPClient.GetCustomHeader(const FieldName: RawByteString): RawByteString; var P : PHTTPCustomHeader; begin P := GetCustomHeaderByName(FieldName); if Assigned(P) then Result := P^.FieldValue else Result := ''; end; procedure TF5HTTPClient.SetCustomHeader(const FieldName: RawByteString; const FieldValue: RawByteString); var P : PHTTPCustomHeader; begin P := GetCustomHeaderByName(FieldName); if Assigned(P) then if StrEqualNoAsciiCaseB(FieldValue, P^.FieldValue) then exit; CheckNotBusyWithRequest; if not Assigned(P) then P := AddCustomHeader(FieldName); Assert(Assigned(P)); P^.FieldValue := FieldValue; end; procedure TF5HTTPClient.SetRequestContentType(const RequestContentType: RawByteString); begin if RequestContentType = FRequestContentType then exit; CheckNotBusyWithRequest; FRequestContentType := RequestContentType; end; function TF5HTTPClient.GetRequestContentMechanism: THTTPContentWriterMechanism; begin Result := FRequestContentWriter.Mechanism; end; procedure TF5HTTPClient.SetRequestContentMechanism(const RequestContentMechanism: THTTPContentWriterMechanism); begin if RequestContentMechanism = FRequestContentWriter.Mechanism then exit; CheckNotBusyWithRequest; FRequestContentWriter.Mechanism := RequestContentMechanism; end; function TF5HTTPClient.GetRequestContentStr: RawByteString; begin Result := FRequestContentWriter.ContentString; end; procedure TF5HTTPClient.SetRequestContentStr(const RequestContentStr: RawByteString); begin if RequestContentStr = FRequestContentWriter.ContentString then exit; CheckNotBusyWithRequest; FRequestContentWriter.ContentString := RequestContentStr; end; function TF5HTTPClient.GetRequestContentStream: TStream; begin Result := FRequestContentWriter.ContentStream; end; procedure TF5HTTPClient.SetRequestContentStream(const RequestContentStream: TStream); begin if RequestContentStream = FRequestContentWriter.ContentStream then exit; CheckNotBusyWithRequest; FRequestContentWriter.ContentStream := RequestContentStream; end; function TF5HTTPClient.GetRequestContentFileName: String; begin Result := FRequestContentWriter.ContentFileName; end; procedure TF5HTTPClient.SetRequestContentFileName(const RequestContentFileName: String); begin if RequestContentFileName = FRequestContentWriter.ContentFileName then exit; CheckNotBusyWithRequest; FRequestContentWriter.ContentFileName := RequestContentFileName; end; procedure TF5HTTPClient.SetRequestContentWwwFormUrlEncodedField(const FieldName, FieldValue: RawByteString); var Req, S : RawByteString; begin Req := GetRequestContentStr; if Req <> '' then S := '&' else S := ''; S := S + FieldName + '=' + FieldValue; Req := Req + S; SetRequestContentType('application/x-www-form-urlencoded'); SetRequestContentStr(Req); end; function TF5HTTPClient.GetResponseContentMechanism: THTTPContentReaderMechanism; begin Result := FResponseContentReader.Mechanism; end; procedure TF5HTTPClient.SetResponseContentMechanism(const ResponseContentMechanism: THTTPContentReaderMechanism); begin if ResponseContentMechanism = FResponseContentReader.Mechanism then exit; CheckNotBusyWithRequest; FResponseContentReader.Mechanism := ResponseContentMechanism; end; function TF5HTTPClient.GetResponseContentFileName: String; begin Result := FResponseContentReader.ContentFileName; end; procedure TF5HTTPClient.SetResponseContentFileName(const ResponseContentFileName: String); begin if ResponseContentFileName = FResponseContentReader.ContentFileName then exit; CheckNotBusyWithRequest; FResponseContentReader.ContentFileName := ResponseContentFileName; end; function TF5HTTPClient.GetResponseContentStream: TStream; begin Result := FResponseContentReader.ContentStream; end; procedure TF5HTTPClient.SetResponseContentStream(const ResponseContentStream: TStream); begin if ResponseContentStream = FResponseContentReader.ContentStream then exit; CheckNotBusyWithRequest; FResponseContentReader.ContentStream := ResponseContentStream; end; procedure TF5HTTPClient.SyncTriggerStateChanged; begin if csDestroying in ComponentState then exit; if Assigned(FOnStateChange) then FOnStateChange(self, FState); end; procedure TF5HTTPClient.SyncTriggerStart; begin if csDestroying in ComponentState then exit; if Assigned(FOnStart) then FOnStart(self); end; procedure TF5HTTPClient.SyncTriggerStop; begin if csDestroying in ComponentState then exit; if Assigned(FOnStop) then FOnStop(self); end; procedure TF5HTTPClient.SyncTriggerActive; begin if csDestroying in ComponentState then exit; if Assigned(FOnActive) then FOnActive(self); end; procedure TF5HTTPClient.SyncTriggerInactive; begin if csDestroying in ComponentState then exit; if Assigned(FOnInactive) then FOnInactive(self); end; procedure TF5HTTPClient.SyncTriggerResponseHeader; begin if csDestroying in ComponentState then exit; if Assigned(FOnResponseHeader) then FOnResponseHeader(self); end; procedure TF5HTTPClient.SyncTriggerResponseContentBuffer; begin if csDestroying in ComponentState then exit; if Assigned(FOnResponseContentBuffer) then FOnResponseContentBuffer(self, FResponseContentBufPtr^, FResponseContentBufSize); end; procedure TF5HTTPClient.SyncTriggerResponseContentComplete; begin if csDestroying in ComponentState then exit; if Assigned(FOnResponseContentComplete) then FOnResponseContentComplete(self); end; procedure TF5HTTPClient.SyncTriggerResponseComplete; begin if csDestroying in ComponentState then exit; if Assigned(FOnResponseComplete) then FOnResponseComplete(self); end; procedure TF5HTTPClient.TriggerStateChanged; begin {$IFDEF HTTP_DEBUG} Log(cltDebug, 'State:%s', [GetStateStr]); {$ENDIF} if Assigned(FOnStateChange) then if FSynchronisedEvents then Synchronize(SyncTriggerStateChanged) else FOnStateChange(self, FState); end; procedure TF5HTTPClient.TriggerStart; begin {$IFDEF HTTP_DEBUG} Log(cltDebug, 'Start'); {$ENDIF} if Assigned(FOnStart) then if FSynchronisedEvents then Synchronize(SyncTriggerStart) else FOnStart(self); end; procedure TF5HTTPClient.TriggerStop; begin {$IFDEF HTTP_DEBUG} Log(cltDebug, 'Stop'); {$ENDIF} if Assigned(FOnStop) then if FSynchronisedEvents then Synchronize(SyncTriggerStop) else FOnStop(self); end; procedure TF5HTTPClient.TriggerActive; begin {$IFDEF HTTP_DEBUG} Log(cltDebug, 'Active'); {$ENDIF} if Assigned(FOnActive) then if FSynchronisedEvents then Synchronize(SyncTriggerActive) else FOnActive(self); end; procedure TF5HTTPClient.TriggerInactive; begin {$IFDEF HTTP_DEBUG} Log(cltDebug, 'Inactive'); {$ENDIF} if Assigned(FOnInactive) then if FSynchronisedEvents then Synchronize(SyncTriggerInactive) else FOnInactive(self); end; procedure TF5HTTPClient.TriggerResponseHeader; begin {$IFDEF HTTP_DEBUG} Log(cltDebug, 'ResponseHeader:'#13#10'%s', [HTTPResponseToStr(FResponse)]); {$ENDIF} if Assigned(FOnResponseHeader) then if FSynchronisedEvents then Synchronize(SyncTriggerResponseHeader) else FOnResponseHeader(self); end; procedure TF5HTTPClient.TriggerResponseContentBuffer(const Buf; const BufSize: Integer); begin {$IFDEF HTTP_DEBUG} Log(cltDebug, 'ContentBuffer:%db', [BufSize]); {$ENDIF} if Assigned(FOnResponseContentBuffer) then if FSynchronisedEvents then begin FResponseContentBufPtr := @Buf; FResponseContentBufSize := BufSize; Synchronize(SyncTriggerResponseContentBuffer); end else FOnResponseContentBuffer(self, Buf, BufSize); end; procedure TF5HTTPClient.TriggerResponseContentComplete; begin {$IFDEF HTTP_DEBUG} Log(cltDebug, 'ContentComplete'); {$ENDIF} if Assigned(FOnResponseContentComplete) then if FSynchronisedEvents then Synchronize(SyncTriggerResponseContentComplete) else FOnResponseContentComplete(self); end; procedure TF5HTTPClient.TriggerResponseComplete; begin {$IFDEF HTTP_DEBUG} Log(cltDebug, 'ResponseComplete'); {$ENDIF} if Assigned(FOnResponseComplete) then if FSynchronisedEvents then Synchronize(SyncTriggerResponseComplete) else FOnResponseComplete(self); end; procedure TF5HTTPClient.ProcessResponseHeader; var L, I : Integer; B : TRawByteStringBuilder; begin FResponseCode := FResponse.StartLine.Code; B := TRawByteStringBuilder.Create; try L := Length(FResponse.Header.SetCookies); FResponseCookies.Clear; for I := 0 to L - 1 do begin B.Clear; BuildStrHTTPSetCookieFieldValue(FResponse.Header.SetCookies[I], B, []); {$IFDEF StringIsUnicode} FResponseCookies.Add(B.AsString); {$ELSE} FResponseCookies.Add(String(B.AsRawByteString)); {$ENDIF} end; FResponseRequireClose := ( (FResponse.StartLine.Version.Version = hvHTTP10) and (FResponse.Header.CommonHeaders.Connection.Value = hcfNone) ) or ( FResponse.Header.CommonHeaders.Connection.Value = hcfClose ); finally B.Free; end; end; procedure TF5HTTPClient.SetResponseComplete; begin if FState in [ hcsResponseCompleteAndClosing, hcsResponseCompleteAndClosed, hcsResponseComplete, hcsRequestInterruptedAndClosed, hcsRequestFailed] then exit; SetState(hcsResponseComplete); TriggerResponseComplete; if FResponseRequireClose then begin SetState(hcsResponseCompleteAndClosing); FTCPClient.Connection.Shutdown; end; end; procedure TF5HTTPClient.SetResponseCompleteThenClosed; begin Assert(FState in [hcsReceivedResponse, hcsReceivingContent]); SetState(hcsResponseComplete); TriggerResponseComplete; SetState(hcsResponseCompleteAndClosed); end; procedure TF5HTTPClient.InitTCPClientHost; begin Assert(Assigned(FTCPClient)); case FAddressFamily of cafIP4 : FTCPClient.AddressFamily := flcTCPClient.cafIP4; cafIP6 : FTCPClient.AddressFamily := flcTCPClient.cafIP6; else raise EHTTPClient.Create('Invalid HTTP client address family'); end; if FHost = '' then raise EHTTPClient.Create(SError_HostNotSet); FTCPClient.Host := FHost; FTCPClient.Port := FPort; FTCPClient.LocalHost := '0.0.0.0'; end; procedure TF5HTTPClient.InitTCPClient; {$IFDEF HTTP_TLS} var TLSOpt : TTCPClientTLSOptions; {$ENDIF} begin FTCPClient := TF5TCPClient.Create(nil); try FTCPClient.OnLog := TCPClientLog; FTCPClient.OnStateChanged := TCPClientStateChanged; FTCPClient.OnError := TCPClientError; FTCPClient.OnProcessThreadIdle := TCPClientIdle; FTCPClient.OnConnected := TCPClientConnected; FTCPClient.OnConnectFailed := TCPClientConnectFailed; FTCPClient.OnReady := TCPClientReady; FTCPClient.OnRead := TCPClientRead; FTCPClient.OnWrite := TCPClientWrite; FTCPClient.OnClose := TCPClientClose; FTCPClient.OnMainThreadWait := TCPClientMainThreadWait; FTCPClient.OnThreadWait := TCPClientThreadWait; {$IFDEF TCPCLIENT_SOCKS} FTCPClient.SocksEnabled := False; {$ENDIF} FTCPClient.SynchronisedEvents := False; {$IFDEF HTTP_TLS} FTCPClient.TLSEnabled := FUseHTTPS; TLSOpt := []; ///// (* if csoDontUseSSL3 in FHTTPSOptions then Include(TLSOpt, ctoDisableSSL3); if csoDontUseTLS10 in FHTTPSOptions then Include(TLSOpt, ctoDisableTLS10); if csoDontUseTLS11 in FHTTPSOptions then Include(TLSOpt, ctoDisableTLS11); if csoDontUseTLS12 in FHTTPSOptions then Include(TLSOpt, ctoDisableTLS12); *) FTCPClient.TLSOptions := TLSOpt; {$ENDIF} InitTCPClientHost; except FreeAndNil(FTCPClient); raise; end; end; procedure TF5HTTPClient.TCPClientLog(Client: TF5TCPClient; LogType: TTCPClientLogType; Msg: String; LogLevel: Integer); begin {$IFDEF HTTP_DEBUG} Log(cltDebug, 'TCP:%s', [Msg], LogLevel + 1); {$ENDIF} end; procedure TF5HTTPClient.TCPClientIdle(Client: TF5TCPClient); begin end; procedure TF5HTTPClient.TCPClientStateChanged(Client: TF5TCPClient; State: TTCPClientState); begin {$IFDEF HTTP_DEBUG} Log(cltDebug, 'TCP_StateChange:%s', [Client.StateStr]); {$ENDIF} end; procedure TF5HTTPClient.TCPClientError(Client: TF5TCPClient; ErrorMsg: String; ErrorCode: Integer); begin {$IFDEF HTTP_DEBUG} Log(cltDebug, 'TCP_Error:%d:%s', [ErrorCode, ErrorMsg]); {$ENDIF} end; procedure TF5HTTPClient.TCPClientConnected(Client: TF5TCPClient); begin {$IFDEF HTTP_DEBUG} Log(cltDebug, 'TCP_Connected'); {$ENDIF} end; procedure TF5HTTPClient.TCPClientConnectFailed(Client: TF5TCPClient); begin {$IFDEF HTTP_DEBUG} Log(cltDebug, 'TCP_ConnectFailed'); {$ENDIF} SetErrorMsg(Client.ErrorMessage); SetState(hcsConnectFailed); end; procedure TF5HTTPClient.TCPClientReady(Client: TF5TCPClient); var ReqPending : Boolean; begin {$IFDEF HTTP_DEBUG} Log(cltDebug, 'TCP_Ready'); {$ENDIF} SetState(hcsConnected_Ready); Lock; try ReqPending := FRequestPending; finally Unlock; end; if ReqPending then try try SendRequest; finally Lock; try FRequestPending := False; finally Unlock; end; end; except on E : Exception do SetRequestFailedFromException(E); end; end; procedure TF5HTTPClient.TCPClientRead(Client: TF5TCPClient); begin {$IFDEF HTTP_DEBUG} Log(cltDebug, 'TCP_Read'); {$ENDIF} ReadResponse; end; procedure TF5HTTPClient.TCPClientWrite(Client: TF5TCPClient); begin {$IFDEF HTTP_DEBUG} Log(cltDebug, 'TCP_Write'); {$ENDIF} end; procedure TF5HTTPClient.TCPClientClose(Client: TF5TCPClient); begin {$IFDEF HTTP_DEBUG} Log(cltDebug, 'TCP_Close'); {$ENDIF} case FState of hcsInit, hcsStopping, hcsConnectFailed, hcsResponseCompleteAndClosed, hcsRequestInterruptedAndClosed : exit; hcsResponseComplete, hcsResponseCompleteAndClosing : SetState(hcsResponseCompleteAndClosed); hcsStarting, hcsSendingRequest, hcsSendingContent, hcsAwaitingResponse : SetState(hcsRequestInterruptedAndClosed); hcsReceivedResponse : if not FResponse.HasContent and FResponseRequireClose then SetResponseCompleteThenClosed else SetState(hcsRequestInterruptedAndClosed); hcsReceivingContent : if FResponseRequireClose and FResponseContentReader.ContentComplete then SetResponseCompleteThenClosed else SetState(hcsRequestInterruptedAndClosed); end; end; procedure TF5HTTPClient.TCPClientMainThreadWait(Client: TF5TCPClient); begin if Assigned(FOnMainThreadWait) then FOnMainThreadWait(self); end; procedure TF5HTTPClient.TCPClientThreadWait(Client: TF5TCPClient); begin if Assigned(FOnThreadWait) then FOnThreadWait(self); end; procedure TF5HTTPClient.SetErrorMsg(const ErrorMsg: String); begin FErrorMsg := ErrorMsg; end; procedure TF5HTTPClient.SetRequestFailedFromException(const E: Exception); begin SetErrorMsg(E.Message); SetState(hcsRequestFailed); end; function TF5HTTPClient.InitRequestContent(out HasContent: Boolean): Int64; var L : Int64; begin FRequestContentWriter.InitContent(HasContent, L); Result := L; end; procedure TF5HTTPClient.FinaliseRequestContent; begin FRequestContentWriter.FinaliseContent; end; procedure TF5HTTPClient.InitResponseContent; begin FResponseContentReader.InitReader(FResponse.Header.CommonHeaders); end; procedure TF5HTTPClient.HandleResponseContent(const Buf; const Size: Integer); begin end; procedure TF5HTTPClient.FinaliseResponseContent(const Success: Boolean); begin end; procedure TF5HTTPClient.ContentWriterLog(const Sender: THTTPContentWriter; const LogMsg: String); begin {$IFDEF HTTP_DEBUG} Log(cltDebug, 'ContentWriter:%s', [LogMsg], 1); {$ENDIF} end; function TF5HTTPClient.ContentWriterWriteProc(const Sender: THTTPContentWriter; const Buf; const Size: Integer): Integer; begin Result := FTCPClient.Connection.Write(Buf, Size); end; procedure TF5HTTPClient.ContentReaderLog(const Sender: THTTPContentReader; const LogMsg: String; const LogLevel: Integer); begin {$IFDEF HTTP_DEBUG} Log(cltDebug, 'ContentReader:%s', [LogMsg], LogLevel + 1); {$ENDIF} end; function TF5HTTPClient.ContentReaderReadProc(const Sender: THTTPContentReader; var Buf; const Size: Integer): Integer; begin Assert(Assigned(FTCPClient)); Assert(FState in [hcsReceivingContent]); // Result := FTCPClient.Connection.Read(Buf, Size); {$IFDEF HTTP_DEBUG} Log(cltDebug, 'ContentReader_Read:%db:%db', [Size, Result]); {$ENDIF} end; procedure TF5HTTPClient.ContentReaderContentProc(const Sender: THTTPContentReader; const Buf; const Size: Integer); begin {$IFDEF HTTP_DEBUG} Log(cltDebug, 'ContentReader_Content:%db', [Size]); {$ENDIF} TriggerResponseContentBuffer(Buf, Size); HandleResponseContent(Buf, Size); end; procedure TF5HTTPClient.ContentReaderCompleteProc(const Sender: THTTPContentReader); begin {$IFDEF HTTP_DEBUG} Log(cltDebug, 'ContentReader_Complete'); {$ENDIF} FinaliseResponseContent(True); TriggerResponseContentComplete; SetResponseComplete; end; procedure TF5HTTPClient.ReadResponseHeader; const HdrBufSize = HTTPCLIENT_ResponseHeader_MaxSize + HTTPCLIENT_ResponseHeader_DelimLen; var HdrBuf : array[0..HdrBufSize - 1] of Byte; HdrLen : Integer; begin Assert(Assigned(FTCPClient)); Assert(FState in [hcsAwaitingResponse]); // HdrLen := FTCPClient.Connection.PeekDelimited( HdrBuf[0], HdrBufSize, HTTPCLIENT_ResponseHeader_Delim, HTTPCLIENT_ResponseHeader_MaxSize); if HdrLen < 0 then exit; ClearHTTPResponse(FResponse); FHTTPParser.SetTextBuf(HdrBuf[0], HdrLen); FHTTPParser.ParseResponse(FResponse); if not FResponse.HeaderComplete then exit; FTCPClient.Connection.Discard(HdrLen); SetState(hcsReceivedResponse); ProcessResponseHeader; TriggerResponseHeader end; procedure TF5HTTPClient.ReadResponseContent; begin FResponseContentReader.Process; end; procedure TF5HTTPClient.ReadResponse; begin if FState = hcsStarting then exit; Assert(FTCPClient.State in [csReady, csClosed]); Assert(FState in [ hcsAwaitingResponse, hcsReceivedResponse, hcsReceivingContent, hcsResponseComplete, hcsResponseCompleteAndClosing, hcsResponseCompleteAndClosed, hcsRequestInterruptedAndClosed]); try if FState = hcsAwaitingResponse then ReadResponseHeader; if FState = hcsReceivedResponse then if FResponse.HasContent then begin InitResponseContent; SetState(hcsReceivingContent); end else SetResponseComplete; if FState = hcsReceivingContent then ReadResponseContent; except on E : Exception do SetRequestFailedFromException(E); end; end; procedure TF5HTTPClient.DoStartTCPClient; begin InitTCPClient; FViaHTTPProxy := FUseHTTPProxy and (FHTTPProxyHost <> ''); Assert(Assigned(FTCPClient)); FTCPClient.Start; end; procedure TF5HTTPClient.DoStart; begin Lock; try if FInDoStart then exit; FInDoStart := True; finally Unlock; end; try TriggerStart; SetState(hcsStarting); DoStartTCPClient; FActive := True; TriggerActive; finally Lock; try FInDoStart := False; finally Unlock; end; end; end; procedure TF5HTTPClient.DoStopTCPClient; begin Assert(Assigned(FTCPClient)); FTCPClient.Stop; end; procedure TF5HTTPClient.DoStop; begin Lock; try if FInDoStart then exit; FInDoStop := True; finally Unlock; end; try TriggerStop; SetState(hcsStopping); DoStopTCPClient; SetState(hcsStopped); FActive := False; TriggerInactive; finally Lock; try FInDoStop := False; finally Unlock; end; end; end; procedure TF5HTTPClient.SetActive(const Active: Boolean); begin if Active = FActive then exit; if csDesigning in ComponentState then FActive := Active else if csLoading in ComponentState then FActivateOnLoaded := Active else if Active then DoStart else DoStop; end; procedure TF5HTTPClient.PrepareHTTPRequest; var C : THTTPConnectionFieldEnum; R : Boolean; L : Int64; begin ClearHTTPRequest(FRequest); case FMethod of cmGET : FRequest.StartLine.Method.Value := hmGET; cmPOST : FRequest.StartLine.Method.Value := hmPOST; cmCustom : begin if FMethodCustom = '' then raise EHTTPClient.Create(SError_MethodNotSet); FRequest.StartLine.Method.Value := hmCustom; FRequest.StartLine.Method.Custom := FMethodCustom; end; else raise EHTTPClient.Create(SError_MethodNotSet); end; if FURI = '' then raise EHTTPClient.Create(SError_URINotSet); FRequest.StartLine.URI := FURI; FRequest.StartLine.Version.Version := hvHTTP11; FRequest.Header.CommonHeaders.Date.Value := hdDateTime; FRequest.Header.CommonHeaders.Date.DateTime := Now; case FKeepAlive of kaKeepAlive : C := hcfKeepAlive; kaClose : C := hcfClose; else C := hcfNone; end; if C <> hcfNone then if FViaHTTPProxy then FRequest.Header.CommonHeaders.ProxyConnection.Value := C else FRequest.Header.CommonHeaders.Connection.Value := C; FRequest.Header.FixedHeaders[hntHost] := UTF8Encode(FHost); FRequest.Header.FixedHeaders[hntUserAgent] := FUserAgent; FRequest.Header.FixedHeaders[hntReferer] := FReferer; FRequest.Header.FixedHeaders[hntAuthorization] := FAuthorization; if FCookie <> '' then begin FRequest.Header.Cookie.Value := hcoCustom; FRequest.Header.Cookie.Custom := FCookie; end; FRequest.Header.CustomHeaders := FCustomHeaders; if FRequestContentType <> '' then begin FRequest.Header.CommonHeaders.ContentType.Value := hctCustomString; FRequest.Header.CommonHeaders.ContentType.CustomStr := FRequestContentType; L := InitRequestContent(R); Assert(L >= 0); FRequest.Header.CommonHeaders.ContentLength.Value := hcltByteCount; FRequest.Header.CommonHeaders.ContentLength.ByteCount := L; FRequestHasContent := True; end else FRequestHasContent := False; end; function TF5HTTPClient.GetHTTPRequestStr: RawByteString; begin Result := HTTPRequestToStr(FRequest); {$IFDEF HTTP_DEBUG} Log(cltDebug, 'RequestHeader:%db'#13#10'%s', [Length(Result), Result]); {$ENDIF} end; procedure TF5HTTPClient.SendStr(const S: RawByteString); begin Assert(Assigned(FTCPClient)); Assert(FState in [hcsSendingRequest, hcsSendingContent]); // FTCPClient.Connection.WriteByteString(S); end; procedure TF5HTTPClient.SendRequest; begin Assert(FState in [hcsConnected_Ready, hcsResponseComplete, hcsResponseCompleteAndClosing]); // SetState(hcsSendingRequest); SendStr(GetHTTPRequestStr); if FRequestHasContent then begin SetState(hcsSendingContent); FRequestContentWriter.SendContent; FinaliseRequestContent; end; SetState(hcsAwaitingResponse); end; procedure TF5HTTPClient.ResetRequest; begin FErrorMsg := ''; ClearHTTPResponse(FResponse); FResponseCode := 0; FResponseCookies.Clear; FResponseContentReader.Reset; FRequestContentWriter.Reset; end; procedure TF5HTTPClient.Request; var R_IsStarting : Boolean; R_Ready : Boolean; R_Connect : Boolean; R_IsActive : Boolean; begin Lock; try // check state if FInRequest or IsBusyWithRequest then raise EHTTPClient.Create(SError_NotAllowedWhileBusyWithRequest); FInRequest := True; R_IsActive := FActive; R_IsStarting := IsBusyStarting; R_Ready := FState in [hcsConnected_Ready, hcsResponseComplete]; R_Connect := not R_IsStarting and not R_Ready; // initialise new request ResetRequest; PrepareHTTPRequest; FRequestPending := not R_Ready; finally Unlock; end; try if R_Connect then begin if R_IsActive then begin DoStopTCPClient; DoStartTCPClient; end else DoStart; end else if R_Ready then SendRequest; finally Lock; try FInRequest := False; finally Unlock; end; end; end; function TF5HTTPClient.RequestIsBusy: Boolean; begin Lock; try Result := IsBusyWithRequest; finally Unlock; end; end; function TF5HTTPClient.RequestIsSuccess: Boolean; begin Result := GetState in HTTPClientState_ResponseComplete; end; function TF5HTTPClient.GetResponseContentStr: RawByteString; begin Result := FResponseContentReader.ContentString; end; procedure TF5HTTPClient.Wait; begin {$IFDEF OS_MSWIN} if GetCurrentThreadID = MainThreadID then begin if Assigned(OnMainThreadWait) then FOnMainThreadWait(self); end else begin if Assigned(FOnThreadWait) then FOnThreadWait(self); end; {$ELSE} if Assigned(FOnThreadWait) then FOnThreadWait(self); {$ENDIF} Sleep(5); end; function TF5HTTPClient.WaitForConnect(const Timeout: Integer): Boolean; var T : LongWord; R : Boolean; begin T := TCPGetTick; repeat Lock; try R := FActive; if not R then break; R := FTCPClient.IsConnected; if R then break; if FTCPClient.State in [csClosed, csStopped] then break; finally Unlock; end; if TCPTickDelta(T, TCPGetTick) >= TimeOut then break; Wait; until false; Result := R; end; function TF5HTTPClient.WaitRequestNotBusy(const Timeout: Integer): Boolean; var T : LongWord; R : Boolean; begin T := TCPGetTick; repeat R := not RequestIsBusy; if R then break; if TCPTickDelta(T, TCPGetTick) >= TimeOut then break; Wait; until false; Result := R; end; { } { THTTPClientCollection } { } constructor THTTPClientCollection.Create(const ItemOwner: Boolean); begin inherited Create; FItemOwner := ItemOwner; end; destructor THTTPClientCollection.Destroy; var I : Integer; begin if FItemOwner then for I := Length(FList) - 1 downto 0 do FreeAndNil(FList[I]); inherited Destroy; end; function THTTPClientCollection.GetCount: Integer; begin Result := Length(FList); end; function THTTPClientCollection.GetItem(const Idx: Integer): TF5HTTPClient; begin Assert(Idx >= 0); Assert(Idx < Length(FList)); Result := FList[Idx]; end; function THTTPClientCollection.Add(const Item: TF5HTTPClient): Integer; var L : Integer; begin Assert(Assigned(Item)); L := Length(FList); SetLength(FList, L + 1); FList[L] := Item; Result := L; end; function THTTPClientCollection.CreateNew: TF5HTTPClient; begin Result := TF5HTTPClient.Create(nil); end; function THTTPClientCollection.AddNew: TF5HTTPClient; var C : TF5HTTPClient; begin C := CreateNew; try Add(C); except C.Free; raise; end; Result := C; end; function THTTPClientCollection.GetItemIndex(const Item: TF5HTTPClient): Integer; var I : Integer; begin for I := 0 to Length(FList) - 1 do if FList[I] = Item then begin Result := I; exit; end; Result := -1; end; procedure THTTPClientCollection.RemoveByIndex(const Idx: Integer); var L, I : Integer; T : TF5HTTPClient; begin L := Length(FList); if (Idx < 0) or (Idx >= L) then raise EHTTPClientCollection.Create('Index out of range'); T := FList[Idx]; for I := Idx to L - 2 do FList[I] := FList[I + 1]; SetLength(FList, L - 1); if FItemOwner then T.Free; end; function THTTPClientCollection.Remove(const Item: TF5HTTPClient): Boolean; var I : Integer; begin I := GetItemIndex(Item); if I >= 0 then begin RemoveByIndex(I); Result := True; end else Result := False; end; procedure THTTPClientCollection.Clear; var I : Integer; begin if FItemOwner then for I := Length(FList) - 1 downto 0 do FreeAndNil(FList[I]); FList := nil; end; {$IFDEF HTTPCLIENT_CUSTOM} {$INCLUDE cHTTPClientImpl.inc} {$ENDIF} end.