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.

联系电话:
020-00000000
联系电话:
020-00000000
联系电话:
020-12345678