rtcwinethttpcliprov.pas

Delphi快速开发Web Server

  Silent:=True;
  Closing:=True;

  InternalDisconnect;

  if assigned(Client_Thread) then
    TRtcThread.PostJob(Client_Thread, Message_WSStop, True);

  FResponseBuffer.Free;
  FResponseBuffer:=nil;

  FReadBuffer:='';
  FCS.Free;

  if hStore<>nil then
    begin
    try
      CertCloseStore(hStore,CERT_STORE_CLOSE_FORCE_FLAG);
    except
      end;
    hStore:=nil;
    hStoreReady:=False;
    end;

  inherited;
  end;

procedure TRtcWInetHttpClientProvider.Enter;
  begin
  FCS.Enter;
  end;

procedure TRtcWInetHttpClientProvider.Leave;
  begin
  FCS.Leave;
  end;

procedure TRtcWInetHttpClientProvider.SetTriggerInvalidResponse(Event: TRtcEvent);
  begin
  FOnInvalidResponse:=Event;
  end;

procedure TRtcWInetHttpClientProvider.TriggerInvalidResponse;
  begin
  if assigned(FOnInvalidResponse) then
    FOnInvalidResponse;
  end;

function TRtcWInetHttpClientProvider.GetClientThread: TRtcThread;
  begin
  Result:=Client_Thread;
  end;

procedure TRtcWInetHttpClientProvider.Connect(Force: boolean);
  begin
  if assigned(Client_Thread) and not inThread then
    TRtcThread.PostJob(Client_Thread, Message_WSOpenConn)
  else
    begin
    if GetMultiThreaded then
      begin
      if not assigned(Client_Thread) then
        begin
        Client_Thread:=TRtcWInetClientThread.Create;
        Client_Thread.RtcConn:=self;
        end;
      Forc:=Force;
      TRtcThread.PostJob(Client_Thread, Message_WSOpenConn);
      end
    else
      OpenConnection;
    end;
  end;

procedure TRtcWInetHttpClientProvider.OpenConnection;
  var
    myPort:integer;
  begin
  if (State=conActive) or (State=conActivating) then Exit; // already connected !!!

  if State<>conInactive then
    raise Exception.Create('Can not connect again, connection in use.');

  if FUseHttps then
    myPort:=StrToIntDef(GetPort,INTERNET_DEFAULT_HTTPS_PORT)
  else
    myPort:=StrToIntDef(GetPort,INTERNET_DEFAULT_HTTP_PORT);

  WinInetLoad;

  try
    if CertStoreType<>certNone then
      WinCryptLoad;

    Lost:=True;
    Closing:=False;
    Silent:=False;

    Request.Init;
    Response.Clear;

    State:=conActivating;

    TriggerConnectionOpening(Forc);

    try
      hSession := InternetOpen(nil, INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
    except
      hSession := nil;
      end;

    if hSession=nil then
      raise RtcWInetException.Create('Error initializing Internet API [Code #'+IntToStr(GetLastError)+'].');

    try
      hConnect := InternetConnect(hSession, PChar(GetAddr), myPort,
                                  PChar(FUserName), PChar(FUserPassword),
                                  INTERNET_SERVICE_HTTP, 0, 0);
    except
      hConnect := nil;
      end;

    if hConnect=nil then
      raise RtcWInetException.Create('Error opening Internet Connection [Code #'+IntToStr(GetLastError)+'].');

    State:=conActive;

    TriggerConnecting;
    TriggerConnect;
  except
    on E:Exception do
      begin
      if hConnect<>nil then
        begin
        InternetCloseHandle(hConnect);
        hConnect:=nil;
        end;
      if hSession<>nil then
        begin
        InternetCloseHandle(hSession);
        hSession:=nil;
        end;

      TriggerConnectionClosing;
      TriggerConnectError(E);
      TriggerReadyToRelease;
      end;
    end;
  end;

procedure TRtcWInetHttpClientProvider.Disconnect;
  var
    hReq:HINTERNET;
  begin
  Lost:=False;
  if assigned(Client_Thread) and not inThread then
    begin
    if TRtcThread.Lock(Client_Thread) then
      try
        if hRequest<>nil then
          begin
          try
            hReq:=hRequest;
            hRequest:=nil;
            InternetCloseHandle(hReq);
          except
            end;
          end;
        TRtcThread.PostJob(Client_Thread, Message_WSCloseConn);
      finally
        TRtcThread.UnLock;
        end;
    end
  else
    InternalDisconnect;
  end;

procedure TRtcWInetHttpClientProvider.InternalDisconnect;
  var
    hReq:HINTERNET;
  begin
  if Closing then Exit;

  Closing:=True;

  State:=conClosing;

  if hRequest<>nil then
    begin
    try
      hReq:=hRequest;
      hRequest:=nil;
      InternetCloseHandle(hReq);
    except
      end;
    end;

  if hConnect<>nil then
    begin
    try
      InternetCloseHandle(hConnect);
    except
      end;
    hConnect:=nil;
    end;

  if hSession<>nil then
    begin
    try
      InternetCloseHandle(hSession);
    except
      end;
    hSession:=nil;
    end;

  if State=conClosing then
    begin
    TriggerDisconnecting;
    TriggerConnectionClosing;

    State:=conInactive;
    try
      TriggerDisconnect;
      if Lost then
        TriggerConnectLost;
    except
      end;

    FHeaderOut:=False;
    FDataWasSent:=False;
    TriggerReadyToRelease;
    end;
  end;

function TRtcWInetHttpClientProvider.Read: string;
  begin
  if not _Active then
    begin
    Result:='';
    Exit;
    end;

  if FResponseBuffer.Size>0 then
    begin
    Result:=FResponseBuffer.Get;
    FResponseBuffer.Clear;
    end
  else
    Result:='';
  end;

procedure TRtcWInetHttpClientProvider.SendHeaderOut(const s:string);
  var
    MyHeader:string;
    certOK:boolean;
    ex:Exception;
    lastErr:DWORD;
  begin
  FHeaderOut:=False;
  FHeaderEx:=False;
  certOK:=False;

  myHeader:=Request.HeaderText;
  repeat
    if hRequest=nil then
      Break
    else if Request.Contentlength=length(s) then // Send content out in 1 API call
      begin
      FHeaderEx:=False;

      if Request.ContentLength=0 then // No content
        begin
        if myHeader<>'' then
          FHeaderOut:=HttpSendRequest(hRequest, Addr(MyHeader[1]), length(MyHeader), nil, 0)
        else
          FHeaderOut:=HttpSendRequest(hRequest, nil, 0, nil, 0);
        end
      else // Content in "s"
        begin
        if myHeader<>'' then
          FHeaderOut:=HttpSendRequest(hRequest, Addr(MyHeader[1]), length(MyHeader), Addr(s[1]), length(s))
        else
          FHeaderOut:=HttpSendRequest(hRequest, nil, 0, Addr(s[1]), length(s));
        end;
      end
    else
      begin

      FBufferIn.dwStructSize := SizeOf(FBufferIn);
      FBufferIn.dwBufferTotal := Request.ContentLength;
      FBufferIn.dwBufferLength := 0;
      FBufferIn.dwHeadersTotal := length(MyHeader);
      FBufferIn.dwHeadersLength := length(MyHeader);
      FBufferIn.dwOffsetHigh := 0;
      FBufferIn.dwOffsetLow := 0;
      if length(MyHeader)>0 then
        FBufferIn.lpcszHeader := Addr(MyHeader[1])
      else
        FBufferIn.lpcszHeader := nil;
      FBufferIn.lpvBuffer := nil;
      FBufferIn.Next := nil;

      FHeaderOut := HttpSendRequestEx(hRequest, @FBufferIn, nil, HSR_INITIATE, 0);
      FHeaderEx := FHeaderOut;
      end;

    if hRequest=nil then
      begin
      FHeaderOut:=False;
      Break;
      end
    else if not FHeaderOut then
      begin
      lastErr:=GetLastError;
      if (lastErr = ERROR_INTERNET_CLIENT_AUTH_CERT_NEEDED) then
        begin
        if certOK or (FCertStoreType=certNone) then
          Break
        else
          begin
          certOK:=True;
          if not SetupCertificate then Break;
          end;
        end
      else if (lastErr = ERROR_INTERNET_INVALID_CA) then
        begin
        if certOK or (FCertStoreType=certNone) then
          Break
        else
          begin
          certOK:=True;
          if not SetupCertificate then Break;
          end;
        end
      else
        Break;
      end;
    until FHeaderOut;

  if not FHeaderOut then
    begin
    if _Active then
      begin
      ex:=RtcWInetException.Create('Error Sending the Request [Code #'+IntToStr(GetLastError)+'].');
      try
        TriggerException(ex);
      finally
        ex.Free;
        end;
      InternalDisconnect;
      end;
    end
  else
    begin
    LenToWrite:=Request.ContentLength-length(s);

    FDataOut:=length(Request.Method)+length(Request.URI)+10;
    if not FHeaderEx then
      begin
      FDataOut:=FDataOut+length(myHeader)+length(s);
      Request.ContentOut:=length(s);
      end
    else
      begin
      FDataOut:=FDataOut+length(myHeader);
      Request.ContentOut:=0;
      end;
    TriggerDataOut;

    FDataWasSent:=True; // will call DataSent
    end;
  end;

procedure TRtcWInetHttpClientProvider.WriteHeader(SendNow:boolean=True);
  var
    ex:Exception;
    hReq:HINTERNET;
  begin
  if not _Active then Exit;

  if FHeaderOut then
    raise Exception.Create('Last header intercepted with new header, before data sent out.');

  if hRequest<>nil then
    begin
    try
      hReq:=hRequest;
      hRequest:=nil;
      InternetCloseHandle(hReq);
    except
      end;
    end;

  if FUseHttps then
    hRequest := HttpOpenRequest(hConnect, PChar(Request.Method), PChar(Request.URI), 'HTTP/1.1',
                '', nil, INTERNET_FLAG_RELOAD or INTERNET_FLAG_NO_CACHE_WRITE or INTERNET_FLAG_SECURE, 0)
  else
    hRequest := HttpOpenRequest(hConnect, PChar(Request.Method), PChar(Request.URI), 'HTTP/1.1',
                '', nil, INTERNET_FLAG_RELOAD or INTERNET_FLAG_NO_CACHE_WRITE, 0);

  if hRequest=nil then
    begin
    if _Active then
      begin
      ex:=RtcWInetException.Create('Error opening HTTP Request [Code #'+IntToStr(GetLastError)+'].');
      try
        TriggerException(ex);
      finally
        ex.Free;
        end;
      InternalDisconnect;
      end;
    Exit;
    end;

  if FUseHttps and (FCertStoreType<>certNone) and not hStoreReady then
    SetupCertificate;

  if SendNow or (Request.ContentLength=0) then
    SendHeaderOut('');

  if hRequest=nil then
    begin
    if _Active then
      InternalDisconnect;
    Exit;
    end;

  if not FHeaderOut then
    begin
    LenToWrite:=Request.ContentLength;
    FDataWasSent:=True;
    end;

  Request.Started:=True;
  Request.Active:=True;
  end;

procedure TRtcWInetHttpClientProvider.WriteHeader(const Header_Text: string; SendNow:boolean=True);
  begin
  if not _Active then Exit;

  Request.HeaderText:=Header_Text;
  WriteHeader(SendNow);
  end;

procedure TRtcWInetHttpClientProvider.Write(const s: string; SendNow:boolean=True);
  var
    bOK:boolean;
    ex:Exception;
    bWritten:DWORD;
  begin
  if not _Active then Exit;

  if not Request.Active then
    raise Exception.Create('Sending data without header.');

  if not FHeaderOut then
    SendHeaderOut(s);

  if s='' then Exit;

  if FHeaderEx then
    begin
    bOK := InternetWriteFile(hRequest, Addr(s[1]), length(s), bWritten);
    if not bOK or (bWritten<>dword(length(s))) then
      if _Active then
        begin
        ex:=RtcWInetException.Create('Error Sending the Request [Code #'+IntToStr(GetLastError)+'].');
        try
          TriggerException(ex);
        finally
          ex.Free;
          end;
        InternalDisconnect;
        Exit;
        end;

    FDataOut:=length(s);
    LenToWrite:=LenToWrite-FDataOut;
    Request.ContentOut:=Request.ContentOut + FDataOut;

    TriggerDataOut;
    FDataWasSent:=True; // will call DataSent
    end;
  end;

procedure TRtcWInetHttpClientProvider.LeavingEvent;