rtcwinethttpcliprov.pas

Delphi快速开发Web Server

{
  "HTTP Client provider (WinInet)" - Copyright (c) Danijel Tkalcec
  @html(<br>)

  Using WinInet API to implement a HTTP Client
  connection provider through HTTP Proxy servers

  @exclude
}
unit rtcWInetHttpCliProv;

{$INCLUDE rtcDefs.inc}

interface

uses
  rtcTrashcan,

  SysUtils,
  Windows,
  Classes,

  rtcSyncObjs,
  rtcThrPool,
  rtcFastStrings,

  rtcLog,
  rtcInfo,
  rtcConn,
  rtcConnProv,
  rtcThrConnProv;

const
  LOG_WINET_ERRORS:boolean=False;

type
  HINTERNET = Pointer;

{ INTERNET_BUFFERS - combines headers and data. May be chained for e.g. file }
{ upload or scatter/gather operations. For chunked read/write, lpcszHeader }
{ contains the chunked-ext }
  PInternetBuffers = ^INTERNET_BUFFERS;
  INTERNET_BUFFERS = record
    dwStructSize: DWORD;      { used for API versioning. Set to sizeof(INTERNET_BUFFERS) }
    Next: PInternetBuffers;   { chain of buffers }
    lpcszHeader: PAnsiChar;       { pointer to headers (may be NULL) }
    dwHeadersLength: DWORD;   { length of headers if not NULL }
    dwHeadersTotal: DWORD;    { size of headers if not enough buffer }
    lpvBuffer: Pointer;       { pointer to data buffer (may be NULL) }
    dwBufferLength: DWORD;    { length of data buffer if not NULL }
    dwBufferTotal: DWORD;     { total size of chunk, or content-length if not chunked }
    dwOffsetLow: DWORD;       { used for read-ranges (only used in HttpSendRequest2) }
    dwOffsetHigh: DWORD;
  end;

  RtcWInetException = class(Exception);

  TRtcWInetHttpClientProvider = class;

  TRtcWInetClientThread = class(TRtcThread)
  public
    RtcConn:TRtcWInetHttpClientProvider;
    Releasing:boolean;

  public
    constructor Create; override;
    destructor Destroy; override;

    function Work(Job:TObject):boolean; override;

    procedure OpenConn;
    procedure CloseConn(_lost:boolean);

    // procedure Connect;
    // procedure Disconnect;
    // procedure Release;
    end;

  TRtcWInetHttpClientProvider = class(TRtcThrClientProvider)
  private
    Client_Thread:TRtcWInetClientThread;

    Forc:boolean;

    FCS:TRtcCritSec;

    FBufferIn:INTERNET_BUFFERS;

    FOnInvalidResponse:TRtcEvent;

    FResponseBuffer:TRtcHugeString;

    FReadBuffer:string;

    FMaxHeaderSize:integer;
    FMaxResponseSize:integer;

    FHeaderOut:boolean;
    FHeaderEx:boolean;
    LenToWrite:int64;

    FRequest:TRtcClientRequest;
    FResponse:TRtcClientResponse;

    FDataWasSent:boolean;

    hSession, hConnect, hRequest: hInternet;
	  hStore, pContext: pointer;
    hStoreReady: boolean;

    FUseHttps: boolean;
    FUserName: string;
    FUserPassword: string;
    FCertSubject: string;
    FCertStoreType: TRtcCertStoreType;

  protected
    procedure Enter; override;
    procedure Leave; override;

    function GetClientThread:TRtcThread; override;

    procedure TriggerInvalidResponse; virtual;

    procedure AcceptResponse; virtual;

    function _Active:boolean;

    procedure OpenConnection;

    function SetupCertificate:boolean;

    procedure SendHeaderOut(const s:string);

  public
    constructor Create; override;
    destructor Destroy; override;

    procedure Connect(Force:boolean=False); override;
    procedure Disconnect; override;
    procedure Release; override;

    procedure InternalDisconnect; override;

    procedure LeavingEvent; virtual;

    procedure SetTriggerInvalidResponse(Event:TRtcEvent);

    procedure WriteHeader(SendNow:boolean=True); overload; virtual;
    procedure WriteHeader(const Header_Text:string; SendNow:boolean=True); overload; virtual;

    procedure Write(const s:string; SendNow:boolean=True); override;
    function Read:string; override;

    property Request:TRtcClientRequest read FRequest write FRequest;
    property Response:TRtcClientResponse read FResponse write FResponse;

    // Max. allowed size of the first (status) line in response header
    property MaxResponseSize:integer read FMaxResponseSize write FMaxResponseSize;
    // Max. allowed size of the complete response Header
    property MaxHeaderSize:integer read FMaxHeaderSize write FMaxHeaderSize;

    // Use HTTPS protocol instead of HTTP
    property useHttps:boolean read FUseHttps write FUseHttps;

    property UserName:string read FUserName write FUserName;
    property UserPassword:string read FUserPassword write FUserPassword;

    property CertStoreType:TRtcCertStoreType read FCertStoreType write FCertStoreType;
    property CertSubject:string read FCertSubject write FCertSubject;
    end;

implementation

const
  INTERNET_DEFAULT_HTTP_PORT = 80;                  {    "     "  HTTP   " }
  INTERNET_DEFAULT_HTTPS_PORT = 443;                {    "     "  HTTPS  " }
  INTERNET_OPEN_TYPE_PRECONFIG = 0;  { use registry configuration }
  INTERNET_SERVICE_HTTP = 3;

  INTERNET_OPTION_SECURITY_FLAGS              = 31;

  INTERNET_FLAG_NO_CACHE_WRITE = $04000000;  { don't write this item to the cache }
  INTERNET_FLAG_RELOAD = $80000000;                 { retrieve the original item }
  INTERNET_FLAG_SECURE = $00800000;  { use PCT/SSL if applicable (HTTP) }

  INTERNET_FLAG_IGNORE_CERT_CN_INVALID        = $00001000; { bad common name in X509 Cert. }
  INTERNET_FLAG_IGNORE_CERT_DATE_INVALID      = $00002000; { expired X509 Cert. }
  INTERNET_FLAG_IGNORE_REDIRECT_TO_HTTPS      = $00004000; { ex: http:// to https:// }
  INTERNET_FLAG_IGNORE_REDIRECT_TO_HTTP       = $00008000; { ex: https:// to http:// }

  SECURITY_FLAG_IGNORE_REVOCATION             = $00000080;
  SECURITY_FLAG_IGNORE_UNKNOWN_CA             = $00000100;
  SECURITY_FLAG_IGNORE_WRONG_USAGE            = $00000200;
  SECURITY_FLAG_IGNORE_CERT_CN_INVALID        = INTERNET_FLAG_IGNORE_CERT_CN_INVALID;
  SECURITY_FLAG_IGNORE_CERT_DATE_INVALID      = INTERNET_FLAG_IGNORE_CERT_DATE_INVALID;
  SECURITY_FLAG_IGNORE_REDIRECT_TO_HTTPS      = INTERNET_FLAG_IGNORE_REDIRECT_TO_HTTPS;
  SECURITY_FLAG_IGNORE_REDIRECT_TO_HTTP       = INTERNET_FLAG_IGNORE_REDIRECT_TO_HTTP;

  INTERNET_ERROR_BASE                         = 12000;
  ERROR_INTERNET_CLIENT_AUTH_CERT_NEEDED      = INTERNET_ERROR_BASE + 44;
  ERROR_INTERNET_INVALID_CA                   = INTERNET_ERROR_BASE + 45;
  HTTP_QUERY_RAW_HEADERS_CRLF                 = 22; { special: all headers }

const
  CRLF = #13#10;

  winetdll = 'wininet.dll';
  wincrypt = 'crypt32.dll';

  CERT_STORE_CLOSE_FORCE_FLAG = 1;

  X509_ASN_ENCODING:DWORD = 1;
  PKCS_7_ASN_ENCODING:DWORD = 65536;

  CERT_FIND_SUBJECT_STR_A = 458759;
  CERT_FIND_SUBJECT_STR_W = 524295;
  CERT_FIND_ISSUER_STR_A = 458756;
  CERT_FIND_ISSUER_STR_W = 524292;

  INTERNET_OPTION_CLIENT_CERT_CONTEXT = 84;

  HSR_INITIATE    = $00000008;                       { iterative operation (completed by HttpEndRequest) }

type
  INTERNET_PORT = Word;

  EWinCryptException=Class(Exception);
  EWinInetException=Class(Exception);

  TRtcBaseMessage=class
    end;

  HCERTSTORE = pointer;
  PCERT_INFO = pointer;

  CERT_CONTEXT = packed record
	  dwCertEncodingType:DWORD;
	  pbCertEncoded:pointer;
	  cbCertEncoded:DWORD;
	  pCertInfo:PCERT_INFO;
	  hCertStore:HCERTSTORE;
    end;

  PCCERT_CONTEXT = ^CERT_CONTEXT;

  {CertOpenSystemStoreA}
  TCertOpenSystemStore =        function(hprov:pointer;
                                         szSubsystemProtocol:LPTSTR):HCERTSTORE; stdcall;
  {CertCloseStore}
  TCertCloseStore =             function(hCertStore:HCERTSTORE;
                                         dwFlags:DWORD):BOOL; stdcall;
  {CertFindCertificateInStore}
  TCertFindCertificateInStore = function(hCertStore:HCERTSTORE;
                                         dwCertEncodingType:DWORD;
                                         dwFindFlags:DWORD;
                                         dwFindType:DWORD;
                                         pvFindPara:PChar;
                                         pPrevCertContext:PCCERT_CONTEXT):PCCERT_CONTEXT; stdcall;
  {CertFreeCertificateContext}
  TCertFreeCertificateContext = function(pCertContext:PCCERT_CONTEXT):BOOL; stdcall;

  {InternetOpen}
  TInternetOpen =               function(lpszAgent: PChar; dwAccessType: DWORD;
                                         lpszProxy, lpszProxyBypass:
                                         PChar; dwFlags: DWORD): HINTERNET; stdcall;

  {InternetConnect}
  TInternetConnect =             function(hInet: HINTERNET; lpszServerName: PChar;
                                          nServerPort: INTERNET_PORT;
                                          lpszUsername: PChar; lpszPassword: PChar;
                                          dwService: DWORD; dwFlags: DWORD;
                                          dwContext: DWORD): HINTERNET; stdcall;

  {InternetCloseHandle}
  TInternetCloseHandle =         function(hInet: HINTERNET): BOOL; stdcall;

  {InternetQueryOption}
  TInternetQueryOption =         function(hInet: HINTERNET; dwOption: DWORD;
                                          lpBuffer: Pointer;
                                          var lpdwBufferLength: DWORD): BOOL; stdcall;

  {HttpOpenRequest}
  THttpOpenRequest =             function(hConnect: HINTERNET; lpszVerb: PChar;
                                          lpszObjectName: PChar;
                                          lpszVersion: PChar; lpszReferrer: PChar;
                                          lplpszAcceptTypes: PLPSTR; dwFlags: DWORD;
                                          dwContext: DWORD): HINTERNET; stdcall;

  {HttpSendRequest}
  THttpSendRequest =             function(hRequest: HINTERNET; lpszHeaders: PChar;
                                          dwHeadersLength: DWORD; lpOptional: Pointer;
                                          dwOptionalLength: DWORD): BOOL; stdcall;

  {HttpSendRequestEx}
  THttpSendRequestEx =           function(hRequest: HINTERNET; lpBuffersIn: PInternetBuffers;
                                          lpBuffersOut: PInternetBuffers;
                                          dwFlags: DWORD; dwContext: DWORD): BOOL; stdcall;

  {HttpEndRequest}
  THttpEndRequest =              function(hRequest: HINTERNET;
                                          lpBuffersOut: PInternetBuffers; dwFlags: DWORD;
                                          dwContext: DWORD): BOOL; stdcall;

  {InternetReadFile}
  TInternetReadFile =            function(hFile: HINTERNET; lpBuffer: Pointer;
                                          dwNumberOfBytesToRead: DWORD;
                                          var lpdwNumberOfBytesRead: DWORD): BOOL; stdcall;

  {InternetWriteFile}
  TInternetWriteFile =           function(hFile: HINTERNET; lpBuffer: Pointer;
                                          dwNumberOfBytesToWrite: DWORD;
                                          var lpdwNumberOfBytesWritten: DWORD): BOOL; stdcall;

  {HttpQueryInfo}
  THttpQueryInfo =               function(hRequest: HINTERNET; dwInfoLevel: DWORD;
                                          lpvBuffer: Pointer; var lpdwBufferLength: DWORD;
                                          var lpdwReserved: DWORD): BOOL; stdcall;

  {InternetSetOption}
  TInternetSetOption =           function(hInet: HINTERNET; dwOption: DWORD;
                                          lpBuffer: Pointer;
                                          dwBufferLength: DWORD): BOOL; stdcall;


var
  CertOpenSystemStore: TCertOpenSystemStore;
  CertCloseStore: TCertCloseStore;
  CertFindCertificateInStore: TCertFindCertificateInStore;
  CertFreeCertificateContext: TCertFreeCertificateContext;

  InternetOpen: TInternetOpen;
  InternetConnect: TInternetConnect;
  InternetCloseHandle: TInternetCloseHandle;
  HttpOpenRequest: THttpOpenRequest;
  HttpSendRequest: THttpSendRequest;
  HttpSendRequestEx: THttpSendRequestEx;
  HttpEndRequest: THttpEndRequest;
  InternetReadFile: TInternetReadFile;
  InternetWriteFile: TInternetWriteFile;
  HttpQueryInfo: THttpQueryInfo;
  InternetSetOption: TInternetSetOption;
  InternetQueryOption: TInternetQueryOption;

  LibCS:TRtcCritSec;

  Message_WSStop,
  Message_WSRelease,
  Message_WSOpenConn,
  Message_WSCloseConn:TRtcBaseMessage;

  FDllHandle:THandle = 0;
  FDllHandle2:THandle = 0;

function WinCryptGetProc(const ProcName : String) : Pointer;
  begin
  if Length(ProcName) = 0 then
    Result := nil
  else
    begin
    Result := GetProcAddress(FDllHandle, @ProcName[1]);
    if Result = nil then
      raise EWinCryptException.Create('Procedure ' + ProcName +
                                      ' not found in ' + wincrypt +
                                      ' Error #' + IntToStr(GetLastError));
    end;
  end;

procedure WinCryptLoad;
  begin
  LibCS.Enter;
  try
    if FDllHandle = 0 then
      begin
      FDllHandle := LoadLibrary(@wincrypt[1]);
      if FDllHandle = 0 then
        raise EWinCryptException.Create('Unable to load ' + wincrypt +
                                      ' Error #' + IntToStr(GetLastError));

      try
        CertOpenSystemStore := TCertOpenSystemStore(WinCryptGetProc('CertOpenSystemStoreA'));
        CertCloseStore := TCertCloseStore(WinCryptGetProc('CertCloseStore'));
        CertFindCertificateInStore := TCertFindCertificateInStore(WinCryptGetProc('CertFindCertificateInStore'));
        CertFreeCertificateContext := TCertFreeCertificateContext(WinCryptGetProc('CertFreeCertificateContext'));
      except
        FreeLibrary(FDllHandle);
        FDllHandle:=0;
        raise;
        end;
      end;
  finally
    LibCS.Leave;
    end;
  end;

procedure WinCryptUnload;
  begin
  LibCS.Enter;
  try
    if FDllHandle<>0 then
      begin
      FreeLibrary(FDllHandle);
      FDllHandle:=0;
      end;
  finally
    LibCS.Leave;
    end;
  end;

function WinInetGetProc(const ProcName : String) : Pointer;
  begin
  if Length(ProcName) = 0 then
    Result := nil
  else
    begin
    Result := GetProcAddress(FDllHandle2, @ProcName[1]);
    if Result = nil then
      raise EWinInetException.Create('Procedure ' + ProcName +
                                      ' not found in ' + winetdll +
                                      ' Error #' + IntToStr(GetLastError));
    end;
  end;

procedure WinInetLoad;
  begin
  LibCS.Enter;
  try
    if FDllHandle2 = 0 then
      begin
      FDllHandle2 := LoadLibrary(@winetdll[1]);
      if FDllHandle2 = 0 then
        raise EWinCryptException.Create('Unable to load ' + winetdll +
                                      ' Error #' + IntToStr(GetLastError));

      try
        InternetOpen := TInternetOpen(WinInetGetProc('InternetOpenA'));
        InternetConnect := TInternetConnect(WinInetGetProc('InternetConnectA'));
        InternetCloseHandle := TInternetCloseHandle(WinInetGetProc('InternetCloseHandle'));
        HttpOpenRequest := THttpOpenRequest(WinInetGetProc('HttpOpenRequestA'));
        HttpSendRequest := THttpSendRequest(WinInetGetProc('HttpSendRequestA'));
        HttpSendRequestEx := THttpSendRequestEx(WinInetGetProc('HttpSendRequestExA'));
        HttpEndRequest := THttpEndRequest(WinInetGetProc('HttpEndRequestA'));
        InternetReadFile := TInternetReadFile(WinInetGetProc('InternetReadFile'));
        InternetWriteFile := TInternetWriteFile(WinInetGetProc('InternetWriteFile'));
        HttpQueryInfo := THttpQueryInfo(WinInetGetProc('HttpQueryInfoA'));
        InternetSetOption := TInternetSetOption(WinInetGetProc('InternetSetOptionA'));
        InternetQueryOption := TInternetQueryOption(WinInetGetProc('InternetQueryOptionA'));
      except
        FreeLibrary(FDllHandle2);
        FDllHandle2:=0;
        raise;
        end;
      end;
  finally
    LibCS.Leave;
    end;
  end;

procedure WinInetUnload;
  begin
  LibCS.Enter;
  try
    if FDllHandle2<>0 then
      begin
      FreeLibrary(FDllHandle2);
      FDllHandle2:=0;
      end;
  finally
    LibCS.Leave;
    end;
  end;

{ TRtcWInetHttpClientProvider }

constructor TRtcWInetHttpClientProvider.Create;
  begin
  inherited;
  FUseHttps:=False;

  FCS:=TRtcCritSec.Create;
  FResponseBuffer:=TRtcHugeString.Create;

  FDataWasSent:=False;
  SetLength(FReadBuffer,32000);
  end;

destructor TRtcWInetHttpClientProvider.Destroy;
  begin