分享一个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<TCPHttpItem>; 
    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; 
end; 
constructor TCPHttpClient.Create; 
begin 
  FRequestList := TCustomDataList<TCPHttpItem>.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; 
    end; 
    Result := TCPHttpItem.Create; 
    Result.WorkState := ws_Work; 
    FRequestList.Add(Result); 
  finally 
    FRequestList.UnLock; 
  end; 
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; 
        end; 
      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; 
          end; 
        finally 
          AParamList.Free; 
        end; 
      end; 
    ht_Put: 
      ; 
  end; 
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; 
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; 
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; 
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; 
end.