unit Sparkle.WinHttp.Engine;

{$I Sparkle.Inc}

interface

{$IFDEF MSWINDOWS}

uses
  Generics.Collections, SysUtils, Classes,
  Sparkle.Http.Engine,
  Sparkle.Http.Headers,
  Sparkle.Uri,
  Sparkle.WinHttp.Api;

type
  THttpProxyMode = (Default, Auto, Custom);

  TWinHttpResponse = class;

  TWinHttpResponseStream = class(THttpResponseStream)
  strict private
    FResponse: TWinHttpResponse;
  strict protected
    function HttpRead(var Buffer; Count: Longint): Longint; override;
  public
    constructor Create(AResponse: TWinHttpResponse);
  end;

  TWinHttpResponse = class(THttpResponse)
  strict private
    FConn: HINTERNET;
    FReq: HINTERNET;
    FContentLoaded: boolean;
    FStatusCode: integer;
    FStatusCodeLoaded: boolean;
    FStatusReason: string;
    FStatusReasonLoaded: boolean;
    FContentLength: Int64;
    FContentLengthLoaded: boolean;
    function QueryHeader(Info: integer): string;
  protected
    function GetContentLength: Int64; override;
    function CreateContentStream: TStream; override;
    function GetContentType: string; override;
    function GetContentEncoding: string; override;
    function GetStatusCode: integer; override;
    function GetStatusReason: string; override;
    procedure UpdateHeaders(AHeaders: THttpHeaders); override;
    property RequestId: HINTERNET read FReq;
  public
    constructor Create(AConn, AReq: HINTERNET);
    destructor Destroy; override;
  end;

  TWinHttpEngine = class(THttpEngine)
  strict private
    FSession: HInternet;
    FBeforeWinHttpSendRequest: TProc<HInternet>;
    FHttpProxyMode: THttpProxyMode;
    FProxyName: string;
    FProxyBypass: string;
    function GetSession: HInternet;
//    FResolveTimeout: integer;
//    FSendTimeout: integer;
//    FConnectTimeout: integer;
//    FReceiveTimeout: integer;
  strict protected
    function DoCreateRequest: THttpRequest; override;
    function DoSend(Request: THttpRequest): THttpResponse; override;
  public
    constructor Create; override;
    destructor Destroy; override;

    procedure ResetSession;
    property BeforeWinHttpSendRequest: TProc<HInternet> read FBeforeWinHttpSendRequest write FBeforeWinHttpSendRequest;
    property ProxyMode: THttpProxyMode read FHttpProxyMode write FHttpProxyMode;
    property ProxyName: string read FProxyName write FProxyName;
    property ProxyBypass: string read FProxyBypass write FProxyBypass;
    property Session: HInternet read GetSession;
//    property ResolveTimeout: integer read FResolveTimeout write FResolveTimeout;
//    property ConnectTimeout: integer read FConnectTimeout write FConnectTimeout;
//    property SendTimeout: integer read FSendTimeout write FSendTimeout;
//    property ReceiveTimeout: integer read FReceiveTimeout write FReceiveTimeout;
  end;

{$ENDIF}

implementation

{$IFDEF MSWINDOWS}

uses
  Winapi.Windows;

type
  TCallbackContext = record
    SSLError: string;
  end;
  PCallbackContext = ^TCallbackContext;

procedure StatusCallback(hInternet: HINTERNET; dwContext: Pointer; dwInternetStatus: DWORD;
  lpvStatusInformation: Pointer; dwStatusInformationLength: DWORD); stdcall;
var
  CertStatus: Integer;
  Msg: string;
begin
  case dwInternetStatus of
    WINHTTP_CALLBACK_STATUS_SECURE_FAILURE:
      begin
        CertStatus := PInteger(lpvStatusInformation)^;
        if (CertStatus and WINHTTP_CALLBACK_STATUS_FLAG_CERT_REV_FAILED) <> 0 then
          Msg := Msg + 'Revocation check failed. ';
        if (CertStatus and WINHTTP_CALLBACK_STATUS_FLAG_INVALID_CERT) <> 0 then
          Msg := Msg + 'Invalid certificate. ';
        if (CertStatus and WINHTTP_CALLBACK_STATUS_FLAG_CERT_REVOKED) <> 0 then
          Msg := Msg + 'Certificate revoked. ';
        if (CertStatus and WINHTTP_CALLBACK_STATUS_FLAG_INVALID_CA) <> 0 then
          Msg := Msg + 'Invalid Certificate Authority. ';
        if (CertStatus and WINHTTP_CALLBACK_STATUS_FLAG_CERT_CN_INVALID) <> 0 then
          Msg := Msg + 'Certificate common name (host) mismatch. ';
        if (CertStatus and WINHTTP_CALLBACK_STATUS_FLAG_CERT_DATE_INVALID) <> 0 then
          Msg := Msg + 'Expired certificate. ';
        if (CertStatus and WINHTTP_CALLBACK_STATUS_FLAG_SECURITY_CHANNEL_ERROR) <> 0 then
          Msg := Msg + 'SSL Library internal error. ';
        Msg := Msg + '(' + IntToHex(CertStatus, 8) + ')';
        PCallbackContext(dwContext)^.SSLError := Msg;
      end;
  end;
end;

{ TWinHttpEngine }

constructor TWinHttpEngine.Create;
begin
  // define default timeouts according to WinHttp documentation
//  FResolveTimeout := 0;
//  FConnectTimeout := 60 * 1000;
//  FSendTimeout := 30 * 1000;
//  FReceiveTimeout := 30 * 1000;
  LoadWinHttpLibrary;
end;

function TWinHttpEngine.DoCreateRequest: THttpRequest;
begin
  Result := THttpRequest.Create;
end;

destructor TWinHttpEngine.Destroy;
begin
  ResetSession;
  inherited;
end;

function TWinHttpEngine.GetSession: HInternet;
var
  dwAccessType: Cardinal;
  pszProxyW: PWideChar;
  pszProxyBypassW: PWideChar;
begin
  if FSession = nil then
  begin
    // Determine proxy settings
    case ProxyMode of
      THttpProxyMode.Auto:
        begin
          dwAccessType := WINHTTP_ACCESS_TYPE_AUTOMATIC_PROXY;
          pszProxyW := WINHTTP_NO_PROXY_NAME;
          pszProxyBypassW := WINHTTP_NO_PROXY_BYPASS;
        end;
      THttpProxyMode.Custom:
        begin
          dwAccessType := WINHTTP_ACCESS_TYPE_NAMED_PROXY;
          pszProxyW := PWideChar(ProxyName);
          pszProxyBypassW := PWideChar(ProxyBypass);
        end
    else
      //THttpProxyMode.Default:
      dwAccessType := WINHTTP_ACCESS_TYPE_DEFAULT_PROXY;
      pszProxyW := WINHTTP_NO_PROXY_NAME;
      pszProxyBypassW := WINHTTP_NO_PROXY_BYPASS;
    end;

    FSession := WinHttpOpen(UserAgent, dwAccessType, pszProxyW, pszProxyBypassW, 0);
    if (FSession = nil) then
    begin
      if GetLastError <> ERROR_INVALID_PARAMETER then
        WinHttpCheck(false, 'Session open failed.');

      dwAccessType := WINHTTP_ACCESS_TYPE_DEFAULT_PROXY;
      pszProxyW := WINHTTP_NO_PROXY_NAME;
      pszProxyBypassW := WINHTTP_NO_PROXY_BYPASS;
      FSession := WinHttpOpen(UserAgent, dwAccessType, pszProxyW, pszProxyBypassW, 0);
    end;
    WinHttpCheck(FSession <> nil, 'Session open failed.');

    if WinHttpSetStatusCallback(FSession, StatusCallback,
      WINHTTP_CALLBACK_FLAG_SECURE_FAILURE, nil) = WINHTTP_INVALID_STATUS_CALLBACK then
      RaiseLastOSError;
  end;
  Result := FSession;
end;

procedure TWinHttpEngine.ResetSession;
begin
  if FSession <> nil then
  begin
    WinHttpCheck(WinHttpCloseHandle(FSession), 'Session close failed.');
    FSession := nil;
  end;
end;

function TWinHttpEngine.DoSend(Request: THttpRequest): THttpResponse;
var
  Conn: HINTERNET;
  Req: HINTERNET;
  AcceptTypes: PWideChar;
  RawHeaders: string;
  BytesWritten: Cardinal;
  ContentLen: Cardinal;
  Version: PWideChar;
  Flags: DWord;
  TimeoutMS: DWord;
  OptionValue: DWord;
  Context: TCallbackContext;
begin
  Conn := WinHttpConnect(Session, PWideChar(Request.AsUri.Host), Request.AsUri.Port, 0);
  WinHttpCheck(Conn <> nil, 'Could not create connection');
  try
    AcceptTypes := nil;
//    if (Request.MajorVersion = 1) and (Request.MinorVersion = 1) then
//      Version := nil
//    else
//      Version := PWideChar(Format('HTTP/%d.%d', [Request.MajorVersion, Request.MinorVersion]));
    Version := nil;

    Flags := 0;
    if SameText(Request.AsUri.Scheme, 'https') then
      Flags := Flags or WINHTTP_FLAG_SECURE;
    Req := WinHttpOpenRequest(Conn, PWideChar(Request.Method),
      PWideChar(Request.AsUri.OriginalPath + Request.AsUri.OriginalQuery + Request.AsUri.OriginalFragment), Version, nil, AcceptTypes, Flags);
    WinHttpCheck(Req <> nil, 'Could not open request');
    try
//      WinHttpCheck(WinHttpSetTimeouts(Req, ResolveTimeout, ConnectTimeout, SendTimeout, ReceiveTimeout));
      TimeoutMS := Request.Timeout;
      WinHttpCheck(WinHttpSetTimeouts(Req, TimeoutMS, TimeoutMS, TimeoutMS, TimeoutMS));
      RawHeaders := Request.Headers.RawWideHeaders;
      ContentLen := Request.ContentLength;

      // Disable redirection
      OptionValue := WINHTTP_DISABLE_REDIRECTS;
      WinHttpCheck(WinHttpSetOption(Req, WINHTTP_OPTION_DISABLE_FEATURE, @OptionValue, SizeOf(OptionValue)));

      // Handle decompression
      if TOSVersion.Check(6, 3) then // Windows 8.1 or newer
      begin
        OptionValue := WINHTTP_DECOMPRESSION_FLAG_ALL;
        WinHttpCheck(WinHttpSetOption(Req, WINHTTP_OPTION_DECOMPRESSION, @OptionValue, SizeOf(OptionValue)));
      end;

      if Assigned(FBeforeWinHttpSendRequest) then
        FBeforeWinHttpSendRequest(Req);

      if not WinHttpSendRequest(Req, PWideChar(RawHeaders), Length(RawHeaders),
        WINHTTP_NO_REQUEST_DATA, 0,
        //WINHTTP_IGNORE_REQUEST_TOTAL_LENGTH,
        ContentLen,
        @Context) then
      begin
        if GetLastError = ERROR_WINHTTP_SECURE_FAILURE then
          WinHttpCheck(false, Context.SSLError)
        else
          WinHttpCheck(false);
      end;

      // Send content
      if ContentLen > 0 then
      begin
        WinHttpCheck(WinHttpWriteData(Req, Request.ContentBuffer, ContentLen, BytesWritten));
        if ContentLen <> BytesWritten then
          raise EHttpEngineException.Create('WinHttp - message body not completely sent');
      end;

      // Receive response
      WinHttpCheck(WinHttpReceiveResponse(Req, nil));

      Result := TWinHttpResponse.Create(Conn, Req);
    except
      WinHttpCloseHandle(Req);
      raise;
    end;
  except
    WinHttpCloseHandle(Conn);
    raise;
  end;
end;

{ TWinHttpResponse }

constructor TWinHttpResponse.Create(AConn, AReq: HINTERNET);
begin
  inherited Create;
  FConn := AConn;
  FReq := AReq;
  FContentLoaded := false;
end;

destructor TWinHttpResponse.Destroy;
begin
  WinHttpCloseHandle(FReq);
  WinHttpCloseHandle(FConn);
  inherited;
end;

function TWinHttpResponse.CreateContentStream: TStream;
begin
  Result := TWinHttpResponseStream.Create(Self);
end;

function TWinHttpResponse.GetContentEncoding: string;
begin
  Result := Headers.Get('content-encoding');
end;

function TWinHttpResponse.GetContentLength: Int64;
var
  TempLength: string;
begin
  if not FContentLengthLoaded then
  begin
    if Chunked then
      FContentLength := -1
    else
    begin
      TempLength := QueryHeader(WINHTTP_QUERY_CONTENT_LENGTH);
      if TempLength = '' then
        FContentLength := 0
      else
      if not TryStrToInt64(TempLength, FContentLength) then
        FContentLength := -1;
    end;
    FContentLengthLoaded := true;
  end;
  Result := FContentLength;
end;

function TWinHttpResponse.GetContentType: string;
begin
  Result := Headers.Get('content-type');
end;

function TWinHttpResponse.GetStatusCode: integer;
var
  Size: Cardinal;
begin
  if not FStatusCodeLoaded then
  begin
    Size := SizeOf(FStatusCode);
    WinHttpCheck(WinHttpQueryHeaders(FReq, WINHTTP_QUERY_STATUS_CODE or WINHTTP_QUERY_FLAG_NUMBER,
      nil, @FStatusCode, Size, nil));
    FStatusCodeLoaded := true;
  end;
  Result := FStatusCode;
end;

function TWinHttpResponse.GetStatusReason: string;
begin
  if not FStatusReasonLoaded then
  begin
    FStatusReason := QueryHeader(WINHTTP_QUERY_STATUS_TEXT);
    FStatusReasonLoaded := true;
  end;
  Result := FStatusReason;
end;

function TWinHttpResponse.QueryHeader(Info: integer): string;
var
  Size: Cardinal;
begin
  WinHttpQueryHeaders(FReq, Info, WINHTTP_HEADER_NAME_BY_INDEX, nil, Size, WINHTTP_NO_HEADER_INDEX);
  if GetLastError <> ERROR_INSUFFICIENT_BUFFER then
    WinHttpCheck(false, Format('Could not query header info (%d)', [Info]));
  SetLength(Result, Size div SizeOf(Char));
  WinHttpCheck(WinHttpQueryHeaders(FReq, Info, WINHTTP_HEADER_NAME_BY_INDEX,
    PWideChar(Result), Size, WINHTTP_NO_HEADER_INDEX));
  SetLength(Result, Size div SizeOf(Char));
end;

procedure TWinHttpResponse.UpdateHeaders(AHeaders: THttpHeaders);
var
  RawHeaders: string;
begin
  RawHeaders := QueryHeader(WINHTTP_QUERY_RAW_HEADERS_CRLF);
  AHeaders.RawWideHeaders := RawHeaders;
end;

{ TWinHttpResponseStream }

constructor TWinHttpResponseStream.Create(AResponse: TWinHttpResponse);
begin
  inherited Create;
  FResponse := AResponse;
end;

function TWinHttpResponseStream.HttpRead(var Buffer; Count: Longint): Longint;
var
  BytesToRetrieve, BytesRead: Cardinal;
begin
  BytesToRetrieve := Count;
  BytesRead := 0;
  WinHttpCheck(WinHttpReadData(FResponse.RequestId, @Buffer, BytesToRetrieve, BytesRead));
  Result := BytesRead;
end;

{$ENDIF}

end.
