rtcwinethttpcliprov.pas

Delphi快速开发Web Server

  begin
  If _Active and FDataWasSent then
    begin
    FDataWasSent:=False;

    if LenToWrite=0 then
      begin
      Request.Complete:=True;
      TriggerDataSent;
      if Request.Complete and not Response.Done then
        AcceptResponse;
      end
    else
      TriggerDataSent;
    end;
  TriggerReadyToRelease;
  end;

procedure TRtcWInetHttpClientProvider.AcceptResponse;
  var
    dwBufLen,dwIndex:DWord;
    LenToRead:int64;

    hReq:HINTERNET;

    InBuffer,
    myHeader:string;

    BytesRead:DWord;

    ex:Exception;

  function ReadNextBlock:boolean;
    var
      ReadNowBytes:int64;
    begin
    BytesRead:=0;

    if LenToRead>0 then
      begin
      ReadNowBytes:=LenToRead;
      if ReadNowBytes>length(FReadBuffer) then
        ReadNowBytes:=length(FReadBuffer);
      end
    else
      ReadNowBytes:=length(FReadBuffer);

    if hRequest=nil then
      Result:=False
    else
      Result:=InternetReadFile(hRequest, Addr(FReadBuffer[1]), ReadNowBytes, BytesRead);

    if Result then
      if BytesRead>0 then
        begin
        FDataIn:=BytesRead;
        TriggerDataIn;
        end;
    end;

  begin
  if not _Active then Exit;

  if not FHeaderOut then // This should not happen!
    raise Exception.Create('AcceptResponse was called before WriteHeader.');

  if FHeaderEx then
    HttpEndRequest(hRequest, nil, 0, 0);

  FHeaderOut:=False;
  Response.Started:=True;
  Response.Receiving:=True;

  FResponseBuffer.Clear;

  // Get Raw Header ...
  myHeader:=' ';
  dwBufLen:=1;
  dwIndex:=0;

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

  try
    if not HttpQueryInfo(hRequest, HTTP_QUERY_RAW_HEADERS_CRLF, Addr(myHeader[1]), dwBufLen, dwIndex) then
      begin
      if not _Active then Exit;

      if GetLastError<>ERROR_INSUFFICIENT_BUFFER then
        begin
        if _Active then
          begin
          ex:=RtcWInetException.Create('Error Reading a Response Header [Code #'+IntToStr(GetLastError)+'].');
          try
            TriggerException(ex);
          finally
            ex.Free;
            end;
          InternalDisconnect;
          end;
        Exit;
        end
      else if hRequest<>nil then
        begin
        SetLength(myHeader, dwBufLen);
        if not HttpQueryInfo(hRequest, HTTP_QUERY_RAW_HEADERS_CRLF, Addr(myHeader[1]), dwBufLen, dwIndex) then
          begin
          if _Active then
            begin
            ex:=RtcWInetException.Create('Error Reading a Response Header [Code #'+IntToStr(GetLastError)+'].');
            try
              TriggerException(ex);
            finally
              ex.Free;
              end;
            InternalDisconnect;
            end;
          Exit;
          end;
        end
      else
        begin
        InternalDisconnect;
        Exit;
        end;
      end
    else
      SetLength(myHeader,dwBufLen);

    FDataIn:=length(myHeader);
    TriggerDataIn;

    Response.HeaderText:=myHeader;

    if Request.Method='HEAD' then
      begin
      LenToRead:=0;
      Response.Done:=True;
      if _Active then
        TriggerDataReceived;
      Exit;
      end
    else if Response['CONTENT-LENGTH']<>'' then
      begin
      LenToRead:=Response.ContentLength;
      if LenToRead=0 then
        begin
        Response.Done:=True;
        if _Active then
          TriggerDataReceived;
        Exit;
        end;
      end
    else
      LenToRead:=-1;

    InBuffer:='';

    while _Active and not Response.Done do
      begin
      if not ReadNextBlock then
        begin
        if _Active then
          begin
          ex:=RtcWInetException.Create('Error Reading a Response Header [Code #'+IntToStr(GetLastError)+'].');
          try
            TriggerException(ex);
          finally
            ex.Free;
            end;
          InternalDisconnect;
          end;
        Exit;
        end
      else if BytesRead>0 then
        InBuffer:=InBuffer+Copy(FReadBuffer,1,BytesRead)
      else if (LenToRead>0) and (BytesRead=0) then
        begin
        if _Active then
          begin
          ex:=RtcWInetException.Create('Error Reading a Response Header [Code #'+IntToStr(GetLastError)+'].');
          try
            TriggerException(ex);
          finally
            ex.Free;
            end;
          InternalDisconnect;
          end;
        Exit;
        end;

      if (LenToRead>0) or (LenToRead=-1) then
        begin
        if (LenToRead>length(InBuffer)) or // need more than we have
           (LenToRead=-1) then // size unknown
          begin
          Response.ContentIn:=Response.ContentIn + length(InBuffer);

          if LenToRead>0 then
            Dec(LenToRead, length(InBuffer))
          else if BytesRead=0 then // last byte read
            begin
            LenToRead:=0;
            Response.Done:=True;
            Request.Active:=False;

            FHeaderOut:=False;
            end;

          FResponseBuffer.Add(InBuffer);

          InBuffer:='';
          end
        else
          begin
          Response.ContentIn:=Response.ContentIn + LenToRead;

          FResponseBuffer.Add(Copy(InBuffer,1,LenToRead));

          Delete(InBuffer,1,LenToRead);

          LenToRead:=0;
          Response.Done:=True;
          Request.Active:=False;

          FHeaderOut:=False;
          end;
        end
      else
        begin
        Response.Done:=True;
        Request.Active:=False;

        FHeaderOut:=False;
        end;

      if not _Active then Exit;

      if Response.Done then
        begin
        TriggerDataReceived;
        Exit;
        end
      else
        begin
        TriggerDataReceived;
        Response.Started:=False;
        end;
      end;
  finally
    if _Active and not Request.Active then
      begin
      FResponseBuffer.Clear;
      if hRequest<>nil then
        begin
        try
          hReq:=hRequest;
          hRequest:=nil;
          InternetCloseHandle(hReq);
        except
          end;
        end;
      end;
    end;
  end;

function TRtcWInetHttpClientProvider._Active: boolean;
  begin
  Result:=not Closing and (FState in [conActive,conActivating]);
  end;

procedure TRtcWInetHttpClientProvider.Release;
  begin
  if assigned(Client_Thread) then
    TRtcThread.PostJob(Client_Thread, Message_WSRelease, True)
  else
    inherited;
  end;

function TRtcWInetHttpClientProvider.SetupCertificate:boolean;
  var
    lpszStoreName,
    lpszSubjectName:PChar;
    dwFlags, dwBuffLen:DWORD;
    pDWFlags:^DWORD;
    res:bool;
  begin
  Result:=False;

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

  if FCertStoreType=certAny then
    begin
    dwBuffLen:=sizeof(dwFlags);
    pdwFlags:=addr(dwFlags);
    InternetQueryOption (hRequest, INTERNET_OPTION_SECURITY_FLAGS,
            pdwFlags, dwBuffLen);

    pdwFlags^ := pdwFlags^
                or SECURITY_FLAG_IGNORE_UNKNOWN_CA
                or SECURITY_FLAG_IGNORE_CERT_CN_INVALID
                or SECURITY_FLAG_IGNORE_CERT_DATE_INVALID
                or SECURITY_FLAG_IGNORE_REDIRECT_TO_HTTPS
                or SECURITY_FLAG_IGNORE_REDIRECT_TO_HTTP;

    res := InternetSetOption (hRequest, INTERNET_OPTION_SECURITY_FLAGS,
                              pdwFlags, dwBuffLen );

    if res then
      begin
      hStoreReady:=True;
      Result:=True;
      end;
    end
  else
    begin
    case FCertStoreType of
      certMY: lpszStoreName := 'MY';
      certCA: lpszStoreName := 'CA';
      certROOT: lpszStoreName := 'ROOT';
      certSPC: lpszStoreName := 'SPC';
      else Exit;
      end;

    hStore := CertOpenSystemStore(nil, lpszStoreName);
    if hStore<>nil then
      begin
      lpszSubjectName:=PChar(FCertSubject);

      pContext := CertFindCertificateInStore(hStore,
          X509_ASN_ENCODING or PKCS_7_ASN_ENCODING,
          0, CERT_FIND_SUBJECT_STR_A, lpszSubjectName, nil);

      if (pContext<>nil) then
        begin
        if hRequest<>nil then
          begin
          res := InternetSetOption(hRequest,
                                   INTERNET_OPTION_CLIENT_CERT_CONTEXT,
                                   pContext, sizeof(CERT_CONTEXT));
          if res then
            begin
            hStoreReady:=True;
            Result:=True;
            end;
          end;
        end;
      end;
    end;
  end;

{ TRtcWInetClientThread }

constructor TRtcWInetClientThread.Create;
  begin
  inherited;
  RtcConn:=nil;
  end;

procedure TRtcWInetClientThread.OpenConn;
  begin
  RtcConn.OpenConnection;
  end;

procedure TRtcWInetClientThread.CloseConn(_lost:boolean);
  begin
  if assigned(RtcConn) then
    begin
    try
      RtcConn.Lost:=_lost;
      if not Releasing then
        RtcConn.InternalDisconnect;
    except
      on E:Exception do
        if LOG_WINET_ERRORS then
          Log('WInetClientThread.CloseConn : RtConn.InternalDisconnect',E);
        // ignore exceptions
      end;
    end;
  end;

destructor TRtcWInetClientThread.Destroy;
  begin
  CloseConn(false);
  if assigned(RtcConn) then
    begin
    try
      if Releasing then
        RtcConn.Free
      else if assigned(RtcConn.Client_Thread) then
        RtcConn.Client_Thread:=nil;
    finally
      RtcConn:=nil;
      end;
    end;
  inherited;
  end;

function TRtcWInetClientThread.Work(Job: TObject):boolean;
  begin
  Result:=False;
  try
    if Job=Message_WSOpenConn then
      OpenConn
    else if Job=Message_WSCloseConn then
      CloseConn(false)
    else if Job=Message_WSStop then
      begin
      RtcConn:=nil;
      Result:=True;

      Free;
      end
    else if Job=Message_WSRelease then
      begin
      Releasing:=True;
      Result:=True;

      Free;
      end
    else
      Result:=inherited Work(Job);
  except
    on E:Exception do
      begin
      if LOG_WINET_ERRORS then
        Log('WInetClientThread.Work',E);
      CloseConn(true);
      // raise;
      end;
    end;
  end;

type
  TMyWinInet=class
    public
    constructor Create;
    destructor Destroy; override;
    end;

var
  MyWinInet:TMyWinInet;

{ TMyWinInet }

constructor TMyWinInet.Create;
  begin
  inherited;
  LibCS:=TRtcCritSec.Create;

  Message_WSOpenConn:=TRtcBaseMessage.Create;
  Message_WSCloseConn:=TRtcBaseMessage.Create;
  Message_WSStop:=TRtcBaseMessage.Create;
  Message_WSRelease:=TRtcBaseMessage.Create;
  end;

destructor TMyWinInet.Destroy;
  begin
  WinInetUnload;
  WinCryptUnload;

  Message_WSOpenConn.Free;
  Message_WSCloseConn.Free;
  Message_WSStop.Free;
  Message_WSRelease.Free;
  LibCS.Free;
  inherited;
  end;

initialization
MyWinInet:=TMyWinInet.Create;
finalization
Garbage(MyWinInet);
end.