cltlssocket.pas

Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码

  {$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'Write'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'Write', E); raise; end; end;{$ENDIF}
end;

procedure TclTlsNetworkStream.Authenticate(ADestination: TStream);
var
  cert: TclCertificate;
  certHandled: Boolean;
begin
  {$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'Authenticate');{$ENDIF}
{$IFDEF LOGGER}
  clPutLogMessage(Self, edInside, 'Authenticate, FSSPIBuffer.Position = %d, FSSPIBuffer.Size = %d', nil, [FSSPIBuffer.Position, FSSPIBuffer.Size]);
{$ENDIF}

  try
    FPacketSize := 0;
    FSSPIResult := SSPI.GenContext(FSSPIBuffer, nil, False);
    if (FSSPIResult = rcCredentialNeeded) then
    begin
      cert := nil;
      certHandled := False;
      if Assigned(OnGetCertificate) then
      begin
        OnGetCertificate(Self, cert, certHandled);
      end;

      FSSPIResult := SSPI.GenContext(FSSPIBuffer, cert, certHandled);
    end;

    if (FSSPIResult = rcCredentialNeeded) then
    begin
      raise EclSSPIError.Create(SSPIErrorQueryLocalCertificate, -1);
    end;

    if (FSSPIResult in [rcOK, rcEncodeNeeded]) then
    begin
      VerifyPeer();
    end;

{$IFDEF LOGGER}
  clPutLogMessage(Self, edInside, 'Authenticate, before case FSSPIResult of, FSSPIBuffer.Position = %d, FSSPIBuffer.Size = %d', nil, [FSSPIBuffer.Position, FSSPIBuffer.Size]);
  clPutLogMessage(Self, edInside, 'Authenticate, before case FSSPIResult of, FSSPIResult = %s', nil, [clSspiReturnCodes[FSSPIResult]]);
{$ENDIF}
    
    case FSSPIResult of
      rcAuthContinueNeeded:
        begin
          if not WriteBuffer(nil, 0) then
          begin
            SetNextAction(saWrite);
          end;
          FSSPIResult := rcAuthDataNeeded;
        end;
      rcEncodeNeeded:
        begin
          AfterRead(FSSPIBuffer, ADestination);
          FSSPIResult := rcOk;
        end;
      rcOK:
        begin
          if (SSPI is TclTlsServerSspi) then
          begin
            FSSPIResult := rcAuthContinueNeeded;
            if not WriteBuffer(nil, 0) then
            begin
              SetNextAction(saWrite);
            end;
            FSSPIResult := rcOk;
          end;
        end;
    end;
  finally
{$IFDEF LOGGER}
  clPutLogMessage(Self, edInside, 'Authenticate, inside finally, FSSPIBuffer.Position = %d, FSSPIBuffer.Size = %d', nil, [FSSPIBuffer.Position, FSSPIBuffer.Size]);
{$ENDIF}
    if not (FSSPIResult in [rcOK, rcAuthContinueNeeded, rcAuthMoreDataNeeded]) then
    begin
      FSSPIBuffer.Size := 0;
    end;
  end;
  if (FSSPIResult = rcOK) then
  begin
    TlsStreamReady();
  end;
{$IFDEF LOGGER}
  clPutLogMessage(Self, edInside, 'Authenticate, before end, FSSPIBuffer.Position = %d, FSSPIBuffer.Size = %d', nil, [FSSPIBuffer.Position, FSSPIBuffer.Size]);
{$ENDIF}
  {$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'Authenticate'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'Authenticate', E); raise; end; end;{$ENDIF}
end;

procedure TclTlsNetworkStream.AfterRead(ABuffer, ADestination: TStream);
var
  oldPos: Int64;
begin
  {$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'AfterRead, ABuffer.Position = %d, ABuffer.Size = %d, FSSPIResult = %s', nil, [ABuffer.Position, ABuffer.Size, clSspiReturnCodes[FSSPIResult]]);{$ENDIF}

  case FSSPIResult of
    rcOk,
    rcAuthDataNeeded:
      begin
        FSSPIBuffer.Size := 0;
        FSSPIBuffer.CopyFrom(ABuffer, ABuffer.Size);
        FSSPIBuffer.Position := 0;
        if (FSSPIResult = rcAuthDataNeeded) then
        begin
          Authenticate(ADestination);
          {$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'AfterRead, %d, Authenticate exit', nil, [FSSPIBuffer.Size]);{$ENDIF}
          Exit;
        end;
      end;
    rcAuthMoreDataNeeded,
    rcMoreDataNeeded:
      begin
        oldPos := FSSPIBuffer.Position;
        FSSPIBuffer.Position := FSSPIBuffer.Size;
        FSSPIBuffer.CopyFrom(ABuffer, ABuffer.Size);
        FSSPIBuffer.Position := oldPos;

{$IFDEF LOGGER}clPutLogMessage(Self, edInside, 'AfterRead, oldPos = %d', nil, [oldPos]);{$ENDIF}
        
        if (FSSPIResult = rcAuthMoreDataNeeded) then
        begin
          Authenticate(ADestination);
          {$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'AfterRead, %d, Authenticate exit', nil, [FSSPIBuffer.Size]);{$ENDIF}
          Exit;
        end;
      end;
  end;

  Assert(ADestination <> nil);
  FSSPIResult := SSPI.Decrypt(FSSPIBuffer, ADestination, FSSPIBuffer);

  {$IFDEF LOGGER}clPutLogMessage(Self, edInside, 'AfterRead, FSSPI.Decrypt %s', nil, [clSspiReturnCodes[FSSPIResult]]);{$ENDIF}

  case FSSPIResult of
    rcOk: FSSPIBuffer.Size := 0;
    rcReAuthNeeded:
      begin
        FSSPIBuffer.Size := 0;
        FNeedAuthenticate := True;
      end;
    rcContinueAndMoreDataNeeded: FSSPIResult := rcMoreDataNeeded;
  end;

  {$IFDEF LOGGER}clPutLogMessage(Self, edInside, 'AfterRead, %d', nil, [ADestination.Size]);{$ENDIF}
  {$IFDEF LOGGER}
    clPutLogMessage(Self, edLeave, 'AfterRead, %d', nil, [FSSPIBuffer.Size]);
      except on E: Exception do begin clPutLogMessage(Self, edLeave, 'AfterRead, %d', E, [FSSPIBuffer.Size]); raise; end; end;
  {$ENDIF}
end;

function TclTlsNetworkStream.WriteBuffer(ABuffer: TStream; ABufferSize: Int64): Boolean;
begin
  if (FWriteData.Size = 0) then
  begin
    if not (FSSPIResult in [rcCompleteNeeded, rcAuthContinueNeeded]) then
    begin
      Assert(ABuffer <> nil);

      FSSPIBuffer.Size := 0;
      SSPI.Encrypt(ABuffer, FSSPIBuffer, ABufferSize); //TODO use FWriteData instead

      FWriteData.CopyFrom(FSSPIBuffer, FSSPIBuffer.Size);
      FSSPIBuffer.Position := 0;
    end else
    begin
      Assert(ABuffer = nil);
      FWriteData.CopyFrom(FSSPIBuffer, FSSPIBuffer.Size);
      FSSPIBuffer.Size := 0;
    end;
    FWriteData.Position := 0;
  end;

  Result := inherited Write(FWriteData);

  if Result then
  begin
    FWriteData.Size := 0;
  end;
end;

procedure TclTlsNetworkStream.UpdateProgress(ABytesProceed: Int64);
begin
end;

procedure TclTlsNetworkStream.TlsUpdateProgress(ABytesProceed: Int64);
begin
  inherited UpdateProgress(ABytesProceed);
end;

function TclTlsNetworkStream.GetSSPI: TclTlsSspi;
begin
  Result := FSSPI;
  Assert(Result <> nil);
end;

procedure TclTlsNetworkStream.StreamReady;
begin
end;

procedure TclTlsNetworkStream.TlsStreamReady;
begin
  inherited StreamReady();
end;

procedure TclTlsNetworkStream.VerifyPeer;
var
  statusText: string;
begin
  if FPeerVerified then Exit;
  
  FPeerVerified := SSPI.Certified;
  statusText := GetSSPIErrorMessage(SSPI.StatusCode);
  if Assigned(OnVerifyPeer) then
  begin
    OnVerifyPeer(Self, SSPI.PeerCertificate, statusText, SSPI.StatusCode, FPeerVerified);
  end;

  if not FPeerVerified then
  begin
    raise EclSSPIError.Create(statusText, SSPI.StatusCode);
  end;
end;

procedure TclTlsNetworkStream.OpenClientSession;
begin
  FreeSSPI();
  FSSPI := TclTlsClientSspi.Create(TargetName);
  FSSPI.CertificateFlags := CertificateFlags;
  FSSPI.TLSFlags := TLSFlags;

  FSSPIBuffer.Size := 0;
  FNeedAuthenticate := True;
  SetNextAction(saWrite);
end;

procedure TclTlsNetworkStream.OpenServerSession;
begin
  FreeSSPI();
  FSSPI := TclTlsServerSspi.Create(RequireClientCertificate);
  FSSPI.CertificateFlags := CertificateFlags;
  FSSPI.TLSFlags := TLSFlags;

  FSSPIBuffer.Size := 0;
  FSSPIResult := rcAuthDataNeeded;
  FNeedAuthenticate := False;
  SetNextAction(saRead);
end;

procedure TclTlsNetworkStream.SetCertificateFlags(const Value: TclCertificateFlags);
begin
  FCertificateFlags := Value;
  if (FSSPI <> nil) then
  begin
    FSSPI.CertificateFlags := FCertificateFlags;
  end;
end;

procedure TclTlsNetworkStream.SetTLSFlags(const Value: TclTlsFlags);
begin
  FTLSFlags := Value;
  if (FSSPI <> nil) then
  begin
    FSSPI.TLSFlags := FTLSFlags;
  end;
end;

procedure TclTlsNetworkStream.Assign(ASource: TclNetworkStream);
var
  src: TclTlsNetworkStream;
begin
  inherited Assign(ASource);
  if (ASource is TclTlsNetworkStream) then
  begin
    src := ASource as TclTlsNetworkStream;
    FTargetName := src.TargetName;
    FCertificateFlags := src.CertificateFlags;
    FTLSFlags := src.TLSFlags;
    FRequireClientCertificate := src.RequireClientCertificate;
  end;
end;

end.