delphi跨平台Http库的封装

最近打算写个小程序，希望跨平台，对于曾经深爱Delphi的我，毫无疑问的选择了Delphi，想写的程序里需要用到http请求，所以就基于自带的http库System.Net.HttpClient里的THTTPClient封装了一个异步的http请求类，其实Delphi自带了TNetHttpClient控件的，但貌似在macOs下使用起来效率很低，所以就自己封装了下，采用任务列队的方式进行处理，匿名方法作为异步回调通知函数，做了一些优化处理，在网络不好的时候情况下进行大量请求，退出程序也不会崩溃。以下是代码：

unit uCPHttpClient;

interface

uses System.Classes, System.SysUtils, System.Net.HttpClient, uXGDataList;

const

V_HttpResponse_Success = 200;

V_HttpResponse_ConnectFail = 12029;

V_HttpResponse_ReadTimeOut = 12002;

type

TCPHttpType = (ht_Get, ht_Post, ht_Put);

TCPHttpResponse = record

StatusCode: Integer;

HttpData: string;

ErrorMsg: string;

end;

TOnResponseEvent = reference to procedure(const AHttpResponse: TCPHttpResponse);

TCPHttpClient = class

private type

TCPWorkState = (ws_Wait, ws_Work);

TCPHttpThread = class(TThread)

private

FOnExecuteProc: TProc;

protected

procedure Execute; override;

public

property OnExecuteProc: TProc read FOnExecuteProc write FOnExecuteProc;

end;

TCPHttpItem = class(TObject)

private

procedure DoHttpReceiveData(const Sender: TObject; AContentLength, AReadCount: Int64; var Abort: Boolean);

function ConvertResponse(const AResponse: IHTTPResponse): TCPHttpResponse; overload;

function ConvertResponse(const AError: string): TCPHttpResponse; overload;

function ReadErrorIDEMessage(const AEMessage: string): Integer;

procedure Excute;

protected

FThread: TCPHttpThread;

FHttp: THTTPClient;

WorkState: TCPWorkState;

OnResponseEvent: TOnResponseEvent;

HttpType: TCPHttpType;

ReqURL, Params, Headers: string;

TryTimes: Integer;

procedure Reset;

procedure Request;

procedure Stop;

procedure UpdateError(const AError: string);

procedure UpdateCompleted(const AResponse: IHTTPResponse);

procedure SynchNotifyResponse(const AHttpResponse: TCPHttpResponse);

public

constructor Create;

destructor Destroy; override;

end;

private

FRequestList: TCustomDataList;

procedure ClearData;

function GetWorkHttpItem: TCPHttpItem;

protected

procedure HttpRequest(const AHttpType: TCPHttpType; const AReqURL, AParams, AHeaders: string;

const AOnResponseEvent: TOnResponseEvent);

public

constructor Create();

destructor Destroy; override;

procedure Get(const AReqURL, AParams, AHeaders: string; const AOnResponseEvent: TOnResponseEvent);

procedure Post(const AReqURL, AParams, AHeaders: string; const AOnResponseEvent: TOnResponseEvent);

end;

implementation

uses System.Threading, uLogSystem;

const

V_MaxTryTimes = 3;

{ TCPHttpClient }

procedure TCPHttpClient.ClearData;

var

I: Integer;

AHttpItem: TCPHttpItem;

begin

FRequestList.Lock;

try

for I := 0 to FRequestList.Count - 1 do

begin

AHttpItem := FRequestList.Items[I];

AHttpItem.FHttp.OnReceiveData := nil;

AHttpItem.Free;

end;

FRequestList.Clear;

finally

FRequestList.UnLock;

end;

constructor TCPHttpClient.Create;

begin

FRequestList := TCustomDataList.Create;

end;

destructor TCPHttpClient.Destroy;

begin

ClearData;

FRequestList.Free;

inherited;

end;

procedure TCPHttpClient.Get(const AReqURL, AParams, AHeaders: string; const AOnResponseEvent: TOnResponseEvent);

begin

HttpRequest(ht_Get, AReqURL, AParams, AHeaders, AOnResponseEvent);

end;

procedure TCPHttpClient.Post(const AReqURL, AParams, AHeaders: string; const AOnResponseEvent: TOnResponseEvent);

begin

HttpRequest(ht_Post, AReqURL, AParams, AHeaders, AOnResponseEvent);

end;

function TCPHttpClient.GetWorkHttpItem: TCPHttpItem;

var

I: Integer;

AHttpItem: TCPHttpItem;

begin

FRequestList.Lock;

try

for I := 0 to FRequestList.Count - 1 do

begin

AHttpItem := FRequestList.Items[I];

if AHttpItem.WorkState = ws_Wait then

begin

Result := AHttpItem;

Result.WorkState := ws_Work;

Exit;

end;

Result := TCPHttpItem.Create;

Result.WorkState := ws_Work;

FRequestList.Add(Result);

finally

FRequestList.UnLock;

end;

procedure TCPHttpClient.HttpRequest(const AHttpType: TCPHttpType; const AReqURL, AParams, AHeaders: string;

const AOnResponseEvent: TOnResponseEvent);

var

AHttpItem: TCPHttpItem;

begin

AHttpItem := GetWorkHttpItem;

AHttpItem.HttpType := AHttpType;

AHttpItem.ReqURL := AReqURL;

AHttpItem.Params := AParams;

AHttpItem.Headers := AHeaders;

AHttpItem.OnResponseEvent := AOnResponseEvent;

AHttpItem.Request;

end;

{ TCPHttpClient.TCPHttpItem }

constructor TCPHttpClient.TCPHttpItem.Create;

begin

FHttp := THTTPClient.Create;

FHttp.OnReceiveData := DoHttpReceiveData;

FHttp.ConnectionTimeout := 3000;

FHttp.ResponseTimeout := 5000;

WorkState := ws_Wait;

FThread := nil;

end;

destructor TCPHttpClient.TCPHttpItem.Destroy;

begin

Reset;

Stop;

FHttp.Free;

inherited;

end;

procedure TCPHttpClient.TCPHttpItem.DoHttpReceiveData(const Sender: TObject; AContentLength, AReadCount: Int64;

var Abort: Boolean);

begin

end;

procedure TCPHttpClient.TCPHttpItem.Excute;

procedure HandleException(const AEMessage: string);

var

AErrorID: Integer;

begin

if FThread.Terminated then

begin

WriteLog(ClassName, 'FThread.Terminated true:' + Integer(Self).ToString);

Exit;

end;

Inc(TryTimes);

AErrorID := ReadErrorIDEMessage(AEMessage);

if ((AErrorID = V_HttpResponse_ConnectFail) or (AErrorID = V_HttpResponse_ReadTimeOut)) and

(TryTimes < V_MaxTryTimes) then

Excute

else

UpdateError(AEMessage);

end;

var

AHttpURL: string;

AParamList: TStringList;

AResponse: IHTTPResponse;

begin

case HttpType of

ht_Get:

begin

if Params.IsEmpty then

AHttpURL := ReqURL

else

AHttpURL := ReqURL + '?' + Params;

try

AResponse := FHttp.Get(AHttpURL);

UpdateCompleted(AResponse);

except

on E: Exception do

begin

HandleException(E.Message);

end;

ht_Post:

begin

AHttpURL := ReqURL;

AParamList := TStringList.Create;

try

AParamList.Text := Trim(Params);

try

AResponse := FHttp.Post(AHttpURL, AParamList);

UpdateCompleted(AResponse);

except

on E: Exception do

begin

HandleException(E.Message);

end;

finally

AParamList.Free;

end;

ht_Put:

;

end;

procedure TCPHttpClient.TCPHttpItem.Request;

begin

if not Assigned(FThread) then

begin

FThread := TCPHttpThread.Create(True);

FThread.FreeOnTerminate := False;

FThread.OnExecuteProc := Excute;

FThread.Start;

end

else

begin

if FThread.Suspended then

{$WARN SYMBOL_DEPRECATED OFF}

FThread.Resume;

{$WARN SYMBOL_DEPRECATED ON}

end;

procedure TCPHttpClient.TCPHttpItem.Reset;

begin

TryTimes := 0;

OnResponseEvent := nil;

WorkState := ws_Wait;

end;

procedure TCPHttpClient.TCPHttpItem.Stop;

begin

if Assigned(FThread) then

begin

if FThread.Suspended then

{$WARN SYMBOL_DEPRECATED OFF}

FThread.Resume;

{$WARN SYMBOL_DEPRECATED ON}

FThread.Terminate;

FThread.WaitFor;

FThread.Free;

FThread := nil;

end;

procedure TCPHttpClient.TCPHttpItem.SynchNotifyResponse(const AHttpResponse: TCPHttpResponse);

var

AResponse: TCPHttpResponse;

begin

AResponse := AHttpResponse;

if AResponse.StatusCode = V_HttpResponse_Success then

WriteLog(ClassName, Format('%d %s', [AResponse.StatusCode, AResponse.HttpData]))

else

WriteLog(ClassName, Format('%d %s', [AResponse.StatusCode, AResponse.ErrorMsg]));

if Assigned(OnResponseEvent) then

TThread.Synchronize(FThread,

procedure

begin

if FThread.Terminated then

Exit;

OnResponseEvent(AResponse);

end);

end;

procedure TCPHttpClient.TCPHttpItem.UpdateError(const AError: string);

begin

SynchNotifyResponse(ConvertResponse(AError));

Reset;

end;

procedure TCPHttpClient.TCPHttpItem.UpdateCompleted(const AResponse: IHTTPResponse);

begin

if Assigned(AResponse) then

begin

SynchNotifyResponse(ConvertResponse(AResponse));

Reset;

end

else

raise Exception.Create('UpdateCompleted AResponse is nil');

end;

function TCPHttpClient.TCPHttpItem.ConvertResponse(const AResponse: IHTTPResponse): TCPHttpResponse;

var

AStringStream: TStringStream;

begin

FillChar(Result, sizeof(TCPHttpResponse), #0);

Result.StatusCode := AResponse.StatusCode;

AStringStream := TStringStream.Create('', TEncoding.UTF8);

try

AStringStream.LoadFromStream(AResponse.ContentStream);

if Result.StatusCode = V_HttpResponse_Success then

Result.HttpData := AStringStream.DataString

else

Result.ErrorMsg := AStringStream.DataString;

finally

AStringStream.Free;

end;

function TCPHttpClient.TCPHttpItem.ReadErrorIDEMessage(const AEMessage: string): Integer;

var

AStartIndex, AStopIndex: Integer;

begin

AStartIndex := Pos('(', AEMessage) + 1;

AStopIndex := Pos(')', AEMessage) - 1;

Result := StrToIntDef(Copy(AEMessage, AStartIndex, AStopIndex - AStartIndex + 1), MaxInt - 1);

end;

function TCPHttpClient.TCPHttpItem.ConvertResponse(const AError: string): TCPHttpResponse;

begin

FillChar(Result, sizeof(TCPHttpResponse), #0);

Result.StatusCode := ReadErrorIDEMessage(AError);

Result.ErrorMsg := AError;

end;

{ TCPHttpClient.TCPHttpThread }

procedure TCPHttpClient.TCPHttpThread.Execute;

begin

inherited;

while not Terminated do

begin

if Assigned(FOnExecuteProc) then

FOnExecuteProc;

if not Terminated then

{$WARN SYMBOL_DEPRECATED OFF}

Suspend;

{$WARN SYMBOL_DEPRECATED ON}

end;

end.

推荐分享