Wininet请求包装类简稿

unit uWnWinetClass;

interface

uses
  Windows,Messages,SysUtils,Classes,WinInet;

const
  CONST_AGENT =  ' Wininet by Enli ';
  BUFFER_SIZE =  4096;

type
  //定义http的请求调用方式
  //TWinWrapVerbs = (wwvGET, wwvPOST, wwvMPOST);
  //定义协议版本
  TWinHttpVersion = (wwvHttp1,wwvHttp11);
  //错误类型，没有错误为wwecNil
  TWinInetErrorCauses = (wwecNil,                             // 0
                         wwecAttemptConnect,                  // 1
                         wwecOpen,                            // 2
                         wwecConnect,                         // 3
                         wwecOpenRequest,                     // 4
                         wwecConfigureRequest,                // 5
                         wwecExecRequest,                     // 6
                         wwecEndRequest,                      // 7
                         wwecTimeOut,                         // 8
                         wwecUPD,                             // 9
                         wwecAbort,                           // 10
                         wwecStatus,                          // 11
                         wwecHeader,                          // 12
                         wwecContentLength,                   // 13
                         wwecContentType,                     // 14
                         wwecReadFile,                        // 15
                         wwecWriteFile);                      // 16

  TProxyInfo =  record
    FProxyType : Integer; //- 1: preConfig  0: noproxy  1: sock4  2: sock5  3: http
    FProxyServer :  string;
    FProxyPort : Integer;
    FProxyUserName :  string;
    FProxyUserPass :  string;
   end;
  TWnWinetClass =  class
   private
    FNet: HINTERNET;
    FRequest: HINTERNET;
    FSession: HINTERNET;
    FRequestStream: TMemoryStream;
    FResponseStream: TMemoryStream;
    FVerb:  string;
    FAbort: Boolean;
    FWininetStateChanged: Boolean;
    FTimeOut: Integer;
    FSecure: Boolean;
    FProxyInfo: TProxyInfo;
    FServerPort: Integer;
    FEncodeUrl:  string;
    FErrInfo:  string;
    FServerPass:  string;
    FServerUser:  string;
    FServerName:  string;
    FProxy :  string;
    FHttpHeader:  string;
    FData:  array [ 0 .. BUFFER_SIZE]  of Char;
    FErrorCause: TWinInetErrorCauses;
    FHttpVersion: TWinHttpVersion;
    FStatus: integer;
    FContentType:  string;
    FContentLength: Int64;
    FTotal: Int64;
    FResponseHeader:  string;
     procedure SetAbort( const Value: Boolean);
     procedure FixServerInfo;
     procedure FixProxyServerInfo;
     function OpenConnection: Boolean;
     function OpenRequest: Boolean;
     function ConfigureRequest: Boolean;
     function PerformMethod: Boolean;
     function DetectProxyServer: DWORD;
     function PortToUse(APort: Integer): Integer;
     function FetchHeader(AFlags: integer): Boolean;
     function ReadResponse: Boolean; // 读取接受数据
     function ReadResponseHeader: Boolean;  //获取返回数据包头
     function FixContentLength: Boolean; // 获取接受数据的大小
     function FixContentType: Boolean; // 获取接受数据的类型
     function FixWinINetError(AError: integer):  string;
     function GetHttpVersion:  string;
     procedure AssignError(AError: TWinInetErrorCauses);
   public
     constructor Create;
     destructor Destroy;  override;
     property Abort: Boolean  read FAbort  write SetAbort;
     property Response: TMemoryStream  read FResponseStream;
     property HttpVersion: TWinHttpVersion  read FHttpVersion  write FHttpVersion;
     property ServerName:  string  read FServerName  write FServerName;
     property ServerPort: Integer  read FServerPort  write FServerPort;
     property ServerUser:  string  read FServerUser  write FServerUser;
     property ServerPass:  string  read FServerPass  write FServerPass;
     property ProxyInfo: TProxyInfo  read FProxyInfo  write FProxyInfo;
     property HttpHeader:  string  read FHttpHeader  write FHttpHeader;
     property ResponseHeader:  string  read FResponseHeader  write FResponseHeader;
     property Status: Integer  read FStatus;
     property ContentLength: Int64  read FContentLength;
     property Total: Int64  read FTotal;
     property ErrInfo:  string  read FErrInfo;
     property ErrorCause: TWinInetErrorCauses  read FErrorCause;
     procedure CleanUp(isAll: Boolean);
     function HttpGet(isUrl: string;iiTimeout:Integer;ASecure:Boolean = False):boolean;
     function HttpPost(isUrl: string;AStream:TMemoryStream;iiTimeout:Integer;ASecure:Boolean = False):boolean;
     class  function StreamToHex(AStream: TMemoryStream):  string;
     class  procedure HexToStream(AStream: TMemoryStream;AHex:  string);
   end;

implementation

{  TWnWinetClass  }

procedure TWnWinetClass.AssignError(AError: TWinInetErrorCauses);
var
  I, H: Integer;
  LTemp:  string;
  LR: Cardinal;
begin
  FErrorCause := AError;
   if Length(FErrInfo) =  0  then
   begin
    LR := GetLastError;
     if (LR <  12000)  or (LR <  12175)  then
     begin
      H := GetModuleHandle( ' wininet.dll ');
      SetLength(LTemp,  256);
      I := FormatMessage(FORMAT_MESSAGE_FROM_HMODULE, Pointer(H), LR,  0,
        PChar(LTemp),  256,  nil);
      SetLength(LTemp, I);
      FErrInfo :=  ' Error  '+IntTostr(LR)+ ' : '+LTemp;
     end
     else
      FErrInfo :=  ' Error  '+IntTostr(LR)+ ' : '+SysErrorMessage(GetLastError);
   end;
end;

procedure TWnWinetClass.CleanUp(isAll: Boolean);
begin
   if isAll  then
   begin
     if Assigned(FRequest)  then
     begin
      InternetCloseHandle(FRequest);
      FRequest :=  nil;
     end;
     if Assigned(FSession)  then
     begin
      InternetCloseHandle(FSession);
      FSession :=  nil;
     end;
     if Assigned(FNet)  then
     begin
      InternetCloseHandle(FNet);
      FNet :=  nil;
     end;
   end;
  //FResponse.Clear;
  SetLength(FProxy, 0);
end;


function TWnWinetClass.ConfigureRequest: Boolean;
   function SetUPD(AOption: DWORD; AUPD: PChar): Boolean;
   begin
    Result := (Length(AUPD) =  0)  or InternetSetOption
      (FRequest, AOption, AUPD, Length(AUPD));
   end;

begin
  Result := False;
   if FAbort  then
    Exit;
  // 设置HTTP头
   { if FFileSize > 0 then
  begin
    if Length(FHttpHeader) > 0 then
      FHttpHeader := FHttpHeader + #13#10'Range: bytes=' + IntTostr(FFileSize)
        + '-'#13#10
    else
      FHttpHeader := 'Range: bytes=' + IntTostr(FFileSize) + '-'#13#10;
  end; }
   if Length(FHttpHeader) >  0  then
   begin
    Result := HttpAddRequestHeaders(FRequest, PWideChar(FHttpHeader), Cardinal
        (- 1), HTTP_ADDREQ_FLAG_ADD  or HTTP_ADDREQ_FLAG_REPLACE);

     if  not Result  then
     begin
      AssignError(wwecConfigureRequest);
      Exit;
     end;
   end;
  // 设置超时
   if (FTimeOut <  1)  or (FTimeOut >  999)  then
    FTimeOut :=  30;
  FTimeOut := FTimeOut *  1000;
  Result := InternetSetOption(FNet, INTERNET_OPTION_CONNECT_TIMEOUT, @FTimeOut,
    SizeOf(integer))  and InternetSetOption
    (FNet, INTERNET_OPTION_RECEIVE_TIMEOUT, @FTimeOut, SizeOf(integer))
     and InternetSetOption(FNet, INTERNET_OPTION_SEND_TIMEOUT, @FTimeOut, SizeOf
      (integer));

   if  not(Result)  then
   begin
    AssignError(wwecTimeOut);
    Exit;
   end;
  // 设置代理用户密码，访问用户密码
   if SetUPD(INTERNET_OPTION_PROXY_USERNAME, PChar(FProxyInfo.FProxyUserName))
     and SetUPD(INTERNET_OPTION_PROXY_PASSWORD, PChar(FProxyInfo.FProxyUserPass)
    )  and SetUPD(INTERNET_OPTION_USERNAME, PChar(FServerPass))  and SetUPD
    (INTERNET_OPTION_PASSWORD, PChar(FServerUser))  then
   else
    AssignError(wwecUPD);

end;

constructor TWnWinetClass.Create;
begin
   inherited;
  FResponseStream := TMemoryStream.Create;
  FRequest :=  nil;
  FSession :=  nil;
  FRequestStream :=  nil;
  FNet :=  nil;
  FAbort := False;
  FSecure := False;
  FWininetStateChanged := False;
  SetLength(FEncodeUrl, 0);
  SetLength(FErrInfo, 0);
  SetLength(FServerUser, 0);
  SetLength(FServerPass, 0);
  SetLength(FProxy, 0);
  FVerb :=  ' GET ';

end;

destructor TWnWinetClass.Destroy;
begin
  FResponseStream.Free;
   inherited;
end;

function TWnWinetClass.DetectProxyServer: DWORD;
begin
   //- 1: preConfig  0: noproxy  1: sock4  2: sock5  3: http
  //Result:
  //INTERNET_OPEN_TYPE_PRECONFIG                    0
  //INTERNET_OPEN_TYPE_DIRECT                       1
  //INTERNET_OPEN_TYPE_PROXY                        3
  //INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY  4
   with FProxyInfo  do
   case (FProxyType- 1)  of
     0: Result := INTERNET_OPEN_TYPE_DIRECT;
     1:
     begin
      Result := INTERNET_OPEN_TYPE_PROXY;
      FProxy := Format( ' socks=%s:%s ',[FProxyServer,Inttostr(FProxyPort)]);
     end;
     2:
     begin
      Result := INTERNET_OPEN_TYPE_PROXY;
      FProxy := Format( ' socks5=%s:%s ',[FProxyServer,Inttostr(FProxyPort)]);
     end;
     3:
     begin
      Result := INTERNET_OPEN_TYPE_PROXY;
      FProxy := Format( ' %s:%s ',[FProxyServer,Inttostr(FProxyPort)]);
     end;
   else
      Result := INTERNET_OPEN_TYPE_PRECONFIG;
   end;
end;

function TWnWinetClass.FetchHeader(AFlags: integer): Boolean;
var
  BufLen, Index: DWORD;
begin
  Result := False;
   if FAbort  then Exit;
  Index :=  0;
  BufLen := BUFFER_SIZE;
  FillChar(FData, BufLen,  0);
  Result := HttpQueryInfo(FRequest, AFlags, @FData, BufLen, Index);
end;

function TWnWinetClass.FixContentLength: Boolean;
var
  LTemp:  string;
begin
  Result := False;
   if FAbort  then Exit;
  Result := FetchHeader(HTTP_QUERY_CONTENT_LENGTH);
  LTemp := FData;
   if Result  then
    FContentLength := StrToInt64Def(LTemp,  0)
   else
    AssignError(wwecContentLength);
end;

function TWnWinetClass.FixContentType: Boolean;
begin
  Result := False;
   if FAbort  then Exit;
  Result := FetchHeader(HTTP_QUERY_CONTENT_TYPE);
   if Result  then
    FContentType := FData
   else
    AssignError(wwecContentType);
end;

procedure TWnWinetClass.FixProxyServerInfo;
var
  ls1ServerName, lsPort:  string;
  liLoc: Integer;
begin
  ls1ServerName := LowerCase(FServerName);
  liLoc := Pos( ' : ', ls1ServerName);
   if liLoc =  0  then Exit;
  lsPort := Copy(ls1ServerName, liLoc +  1, Length(ls1ServerName) - liLoc);
  FServerName := PChar(Copy(ls1ServerName,  1, liLoc -  1));
  FServerPort := StrToIntDef(lsPort,FServerPort);
end;

procedure TWnWinetClass.FixServerInfo;
var
  ls1ServerName, lsPort:  string;
  liLoc: Integer;
begin
   if FProxyInfo.FProxyType =  0  then Exit;
  ls1ServerName := LowerCase(FProxyInfo.FProxyServer);
  liLoc := Pos( ' : ', ls1ServerName);
   if liLoc =  0  then Exit;
  lsPort := Copy(ls1ServerName, liLoc +  1, Length(ls1ServerName) - liLoc);
  FProxyInfo.FProxyServer := PChar(Copy(ls1ServerName,  1, liLoc -  1));
  FProxyInfo.FProxyPort := StrToIntDef(lsPort,FProxyInfo.FProxyPort);
end;

function TWnWinetClass.FixWinINetError(AError: integer):  string;
begin
  //Result :=  ' Http Status:  ' + IntTostr(AError);
   if FetchHeader(HTTP_QUERY_STATUS_TEXT)  then
    Result := FData
  // if  not Result  then
   else
   begin
    AssignError(wwecStatus);
    Exit;
   end;
end;

function TWnWinetClass.GetHttpVersion:  string;
begin
   if FHttpVersion = wwvHttp1  then
    Result :=  ' HTTP/1.0 '
   else
    Result :=  ' HTTP/1.1 ';
end;

class  procedure TWnWinetClass.HexToStream(AStream: TMemoryStream;AHex:  string);
var
  I,iLen: Integer;
  LTemp:  string;
  LB : Byte;
begin
  iLen := Length(AHex);
   if (iLen  mod  3) <>  0  then
   begin
    Assert(False, ' hex字符串错误 ');
    Exit;
   end;
   for I :=  0  to (iLen  div  3) -  1  do
   begin
    LTemp := Copy(AHex,I* 3+ 1, 2);
    LB := StrToIntDef( ' $ '+LTemp, 0);
    AStream.WriteBuffer(Lb, 1);
    //Assert(Pos(IntToStr(LB),LTemp)= 0, ' asdf ');
   end;


end;

function TWnWinetClass.HttpGet(isUrl:  string; iiTimeout: integer;
  ASecure: Boolean): boolean;
begin
  FVerb :=  ' GET ';
  FRequest :=  nil;
  FRequestStream :=  nil;
  SetLastError( 0);
  FErrInfo :=  '';
  FErrorCause := wwecNil;
  Result := False;
  FEncodeUrl := isUrl;
  FTimeOut := iiTimeout;
  FSecure := ASecure;
  FixServerInfo;
  FixProxyServerInfo;
  Result := OpenConnection
   and OpenRequest
   and ConfigureRequest
   and PerformMethod;
  CleanUp(True);
end;

function TWnWinetClass.HttpPost(isUrl:  string; AStream: TMemoryStream;
  iiTimeout: Integer; ASecure: Boolean): boolean;
begin
  FVerb :=  ' POST ';
  FRequestStream := AStream;
  SetLastError( 0);
  FErrInfo :=  '';
  FErrorCause := wwecNil;
  Result := False;
  FEncodeUrl := isUrl;
  FTimeOut := iiTimeout;
  FSecure := ASecure;
  FixServerInfo;
  FixProxyServerInfo;
  Result := OpenConnection
   and OpenRequest
   and ConfigureRequest
   and PerformMethod;
  CleanUp(True);
end;

function TWnWinetClass.OpenConnection: Boolean;
var
  LProxyType: DWORD;

   function WW_AttemptConnect: Boolean;
   begin
    Result := (CompareText(FServerName,  ' localhost ') =  0)  or
      (InternetAttemptConnect( 0) = ERROR_SUCCESS);
     if  not (Result)  then AssignError(wwecAttemptConnect);
   end;

   procedure CancelMaxConnectLimite();
   var
    liPerServer1, liPerServer2: Integer;
   begin
     try
      liPerServer1 :=  5;
      liPerServer2 :=  10;
      //INTERNET_OPTION_MAX_CONNS_PER_SERVER   73
      InternetSetOption( nil,  73, @liPerServer1, SizeOf(Integer));
      //INTERNET_OPTION_MAX_CONNS_PER_ 1_ 0_SERVER   74
      InternetSetOption( nil,  74, @liPerServer2, SizeOf(Integer));
     except
     end;
   end;

   function WW_InternetOpen: Boolean;
   var
    ltInfo: INTERNET_CONNECTED_INFO;
   begin
    FNet := InternetOpen(PChar(CONST_AGENT), LProxyType, PChar(FProxy),  nil,  0);

    Result := (FNet <>  nil);
     if Result  then  begin
       try
         if  not FWininetStateChanged  then  begin
          //INTERNET_OPTION_CONNECTED_STATE   50
          //取消IE的脱机状态
          ltInfo.dwConnectedState := INTERNET_STATE_CONNECTED;
          ltInfo.dwFlags :=  0;          // ISO_FORCE_DISCONNECTED;
          InterNetSetOption(FNet, INTERNET_OPTION_CONNECTED_STATE, @ltInfo, SizeOf(ltInfo));
         end;
       except
       end;
      //InternetSetStatusCallBack(FNet, @StatusCallBack);

      //INTERNET_OPTION_HTTP_DECODING
       if InternetSetOption(FNet,  65, @Result,  1)  then  begin
        Beep;
       end;
     end  else  begin
      AssignError(wwecOpen);
     end;
   end;

   function WW_InternetConnect: Boolean;
   var
    context: dword;
   begin
    //同步通讯设置
    context :=  0;
    //异步通讯需要设置特定值
    //FCallBackContext.CallbackID :=  0;
    //context:=dword(@FCallBackContext);
    FSession := InternetConnect(FNet, PChar(FServerName),
        PortToUse(FServerPort),  '',  '', INTERNET_SERVICE_HTTP,  0, context);
    Result := (FSession <>  nil);
     if  not (Result)  then AssignError(wwecConnect);
   end;

begin
  Result := False;
   if FAbort  then Exit;
   if WW_AttemptConnect  then
   begin
    LProxyType := DetectProxyServer;
    SetLastError( 0);
     if  not FWininetStateChanged  then CancelMaxConnectLimite();
    Result := WW_InternetOpen  and WW_InternetConnect;
    FWininetStateChanged := True;
   end;
end;

function TWnWinetClass.OpenRequest: Boolean;
var
  context, ATimeOut, dwFlags: DWORD;
begin
  Result := False;
   if FAbort  then
    Exit;
  context :=  0;
   if FSecure  then
   begin
    FRequest := HTTPOpenRequest(FSession, PChar(FVerb), PChar(FEncodeUrl), PChar
        (GetHttpVersion),  nil,  nil,
      INTERNET_FLAG_KEEP_CONNECTION  or INTERNET_FLAG_SECURE  or
        SECURITY_FLAG_IGNORE_UNKNOWN_CA  or SECURITY_FLAG_IGNORE_CERT_CN_INVALID
         or SECURITY_FLAG_IGNORE_CERT_DATE_INVALID, context);
    ATimeOut :=  0;
    dwFlags :=  0;

     if (FRequest <>  nil)  and ( not InternetQueryOption(FRequest,
        INTERNET_OPTION_SECURITY_FLAGS, Pointer(@ATimeOut), dwFlags))  then
     begin
      GetLastError;
     end;
   end
   else
   begin
    FRequest := HTTPOpenRequest(FSession, PChar(FVerb), PChar(FEncodeUrl), PChar
        (getHttpVersion),  nil,  nil,  {  Ord(FSecure) * INTERNET_FLAG_SECURE or  }
      INTERNET_FLAG_NO_CACHE_WRITE  or INTERNET_FLAG_RELOAD  or
        INTERNET_FLAG_KEEP_CONNECTION, context);
   end;
  Result := (FRequest <>  nil);
   if  not(Result)  then
    AssignError(wwecOpenRequest);
end;

function TWnWinetClass.PerformMethod: Boolean;
var
  ATimeOut, dwFlags: DWORD;
  // LErr: Cardinal;
begin
  Result := False;
   if FAbort  then Exit;
   if Assigned(FRequestStream)  and (FRequestStream.Size >  0)  then
    Result := HTTPSendRequest(FRequest,  nil,  0, FRequestStream.Memory, FRequestStream.Size)
   else
    Result := HTTPSendRequest(FRequest,  nil,  0,  nil,  0);
  // Result := HTTPSendRequest(FRequest, D_C_T, D_C_T_S,  nil,  0);
   if  not(Result)  then
   begin
     if GetLastError = ERROR_INTERNET_INVALID_CA  then // WinInet 无效证书颁发机构错误
     begin
      ATimeOut :=  0;
      dwFlags :=  0;
      InternetQueryOption(FRequest, INTERNET_OPTION_SECURITY_FLAGS, Pointer
          (@ATimeOut), dwFlags);
      dwFlags := dwFlags  or SECURITY_FLAG_IGNORE_UNKNOWN_CA;
      InternetSetOption(FRequest, INTERNET_OPTION_SECURITY_FLAGS, @dwFlags,
        SizeOf(integer));
      Result := HTTPSendRequest(FRequest,  nil,  0,  nil,  0);
     end
     else
     begin
      AssignError(wwecExecRequest);
      Exit;
     end;
   end;

  Result := ReadResponseHeader
     and FixContentLength  and FixContentType  and ReadResponse;

end;

function TWnWinetClass.PortToUse(APort: Integer): Integer;
begin
   if APort >  0  then
    Result := APort
   else
     if FSecure  then
      Result := INTERNET_DEFAULT_HTTPS_PORT
     else
      Result := INTERNET_DEFAULT_HTTP_PORT;
end;

function TWnWinetClass.ReadResponse: Boolean;
var
  ASize, ARead: DWORD;
  ABuffer: Pointer;
begin
  Result := False;
   if FAbort  then Exit;
  FResponseStream.Clear;
  ASize := BUFFER_SIZE;
  FTotal :=  0;
  ABuffer := AllocMem(ASize);
   try
    // HookDataReadSized;
     repeat
      Result := InternetReadFile(FRequest, ABuffer, ASize, ARead);
       if  not Result  then
       begin
        AssignError(wwecReadFile);
        Break;
       end;
       if (ARead >  0)  then
       begin
        FResponseStream.WriteBuffer(ABuffer^, ARead);
        Inc(FTotal, ARead);
        //FTotal := ARead;
        //HookDataReadSized;
       end;
     until ((ARead =  0)  or FAbort);
    FResponseStream.Seek( 0, 0);
   finally
    FreeMem(ABuffer,  0);
   end;
end;

function TWnWinetClass.ReadResponseHeader: Boolean;
begin
  Result := False;
   if FAbort  then Exit;
  Result := FetchHeader(HTTP_QUERY_STATUS_CODE);
   if  not Result  then
   begin
    AssignError(wwecStatus);
    Exit;
   end;
  FStatus := StrToIntDef(FData, - 1);
   if FAbort  then Exit;
  Result := FetchHeader(HTTP_QUERY_RAW_HEADERS_CRLF);
   if Result  then
    FResponseHeader := FData
   else
    AssignError(wwecHeader);
end;

procedure TWnWinetClass.SetAbort( const Value: Boolean);
begin
  FAbort := Value;
end;

class  function TWnWinetClass.StreamToHex(AStream: TMemoryStream):  string;
var
  I: Integer;
  Lb: Byte;
begin
  Result :=  '';
  AStream.Seek( 0, 0);
   for I :=  1  to AStream.Size  do
   begin
    AStream.ReadBuffer(LB, 1);
    Result := Result + IntToHex(Ord(Lb), 2)+  '   ';
    // if (I  mod ALen) =  0  then
    //  Result := Result + # 13# 10;
   end;

end;

end.