clsspi.pas

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

        Result := rcAuthMoreDataNeeded;
        Break;
      end;
      if (FStatusCode = SEC_E_OK) then
      begin
        Result := rcOk;
        if (InBuffers[1].BufferType = SECBUFFER_EXTRA) then
        begin
          ABuffer.Position := ABuffer.Size - Integer(InBuffers[1].cbBuffer);
          Result := rcEncodeNeeded;
        end;
        Break;
      end;
      if (FStatusCode = SEC_I_INCOMPLETE_CREDENTIALS) then
      begin
        if not GenCredentials(ACertificate, AllowEmptyCred, ASecData, SECPKG_CRED_OUTBOUND) then
        begin
          Result := rcCredentialNeeded;
        end;
        NeedToRead := False;
        FStatusCode := SEC_I_INCOMPLETE_CREDENTIALS;
        if (Result = rcCredentialNeeded) then
        begin
         Break;
        end else
        begin
          continue;
        end;
      end;

      CheckSspiError(FStatusCode);

      if (InBuffers[1].BufferType = SECBUFFER_EXTRA) then
      begin
        ABuffer.Position := ABuffer.Size - Integer(InBuffers[1].cbBuffer);
      end else
      begin
        ABuffer.Size := 0;
      end;
    end;
  finally
    FreeMem(buf);
  end;
{$IFDEF LOGGER}
  clPutLogMessage(Self, edInside, 'ContinueConversation, before end, ABuffer.Position = %d, ABuffer.Size = %d', nil, [ABuffer.Position, ABuffer.Size]);
{$ENDIF}
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'ContinueConversation'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'ContinueConversation', E); raise; end; end;{$ENDIF}
end;

function TclTlsClientSspi.VerifyServerCertificate: Boolean;
const
  SECURITY_FLAG_IGNORE_REVOCATION             = $00000080;
  SECURITY_FLAG_IGNORE_UNKNOWN_CA             = $00000100;
  SECURITY_FLAG_IGNORE_WRONG_USAGE            = $00000200;
  SECURITY_FLAG_IGNORE_CERT_CN_INVALID        = $00001000;
  SECURITY_FLAG_IGNORE_CERT_DATE_INVALID      = $00002000;

var
  polHttps: HTTPSPolicyCallbackData;
  PolicyPara: CERT_CHAIN_POLICY_PARA;
  PolicyStatus: CERT_CHAIN_POLICY_STATUS;
  ChainPara: CERT_CHAIN_PARA;
  pChainContext: PCCERT_CHAIN_CONTEXT;
  remoteCertContext: PCCERT_CONTEXT;
  pwszServerName: PWCHAR;
  cchServerName: DWORD;
begin
  FreePeerCertificate();
  Result := True;
  cchServerName := MultiByteToWideChar(CP_ACP, 0, PChar(FTargetname), -1, nil, 0);
  GetMem(pwszServerName, cchServerName * sizeof(WCHAR));
  try
    SetSspiErrorIf(pwszServerName = nil, SEC_E_OUTOFMEMORY);

    MultiByteToWideChar(CP_ACP, 0, PChar(FTargetname), -1, pwszServerName, cchServerName);

    ZeroMemory(@ChainPara, sizeof(ChainPara));
    ChainPara.cbSize := sizeof(ChainPara);

    FStatusCode := FunctionTable.QueryContextAttributes(@FCtxtHandle,
                                    SECPKG_ATTR_REMOTE_CERT_CONTEXT,
                                    @remoteCertContext);
    CheckSspiError(FStatusCode);

    FPeerCertificate := TclCertificate.Create(remoteCertContext);

    pChainContext := nil;
    try
      SetSspiErrorIf(
        not CertGetCertificateChain(
          0,
          remoteCertContext,
          nil,
          remoteCertContext^.hCertStore,
          @ChainPara,
          0,
          nil,
          @pChainContext),
        SSPI_E_WhileVerify);

      ZeroMemory(@polHttps, sizeof(HTTPSPolicyCallbackData));
      polHttps.cbSize := sizeof(HTTPSPolicyCallbackData);
      polHttps.dwAuthType := AUTHTYPE_SERVER;
      polHttps.fdwChecks := 0;

      if cfIgnoreCommonNameInvalid in CertificateFlags then
        polHttps.fdwChecks := polHttps.fdwChecks or SECURITY_FLAG_IGNORE_CERT_CN_INVALID;
      if cfIgnoreDateInvalid in CertificateFlags then
        polHttps.fdwChecks := polHttps.fdwChecks or SECURITY_FLAG_IGNORE_CERT_DATE_INVALID;
      if cfIgnoreUnknownAuthority in CertificateFlags then
        polHttps.fdwChecks := polHttps.fdwChecks or SECURITY_FLAG_IGNORE_UNKNOWN_CA;
      if cfIgnoreRevocation in CertificateFlags then
        polHttps.fdwChecks := polHttps.fdwChecks or SECURITY_FLAG_IGNORE_REVOCATION;
      if cfIgnoreWrongUsage in CertificateFlags then
        polHttps.fdwChecks := polHttps.fdwChecks or SECURITY_FLAG_IGNORE_WRONG_USAGE;

      polHttps.pwszServerName := pwszServerName;

      ZeroMemory(@PolicyPara, sizeof(PolicyPara));
      PolicyPara.cbSize := sizeof(PolicyPara);
      PolicyPara.pvExtraPolicyPara := @polHttps;

      ZeroMemory(@PolicyStatus, sizeof(PolicyStatus));
      PolicyStatus.cbSize := sizeof(PolicyStatus);

      SetSspiErrorIf(
        not CertVerifyCertificateChainPolicy(
          CERT_CHAIN_POLICY_SSL,
          pChainContext,
          @PolicyPara,
          @PolicyStatus),
        SSPI_E_WhileVerify);

      if (PolicyStatus.dwError <> 0) then
      begin
        FStatusCode := Longint(PolicyStatus.dwError);
        Result := False;
      end;
    finally
      if (pChainContext <> nil) then
      begin
        CertFreeCertificateChain(pChainContext);
      end;
      if (remoteCertContext <> nil) then CertFreeCertificateContext(remoteCertContext);
    end;
  finally
    FreeMem(pwszServerName);
  end;
end;

{ TclTlsServerSspi }

constructor TclTlsServerSspi.Create(ARequireClientCertificate: Boolean);
begin
  inherited Create();
  FRequireClientCertificate := ARequireClientCertificate;
end;

function TclTlsServerSspi.EndSession(ABuffer: TStream): TclSspiReturnCode;
var
  OutBuffer: TSecBufferDesc;
  OutBuffers: array[0..1] of TSecBuffer;
  dwSSPIFlags, dwSSPIOutFlags: DWORD;
  tsExpiry: TTimeStamp;
  dwType: Cardinal;
begin
  FNewConversation := True;
  FCertified := False;

  dwType := SCHANNEL_SHUTDOWN;
  dwSSPIFlags := ASC_REQ_SEQUENCE_DETECT + ASC_REQ_REPLAY_DETECT +
      ASC_REQ_CONFIDENTIALITY + ASC_REQ_EXTENDED_ERROR +
      ASC_REQ_ALLOCATE_MEMORY + ASC_REQ_STREAM;

  OutBuffer.ulVersion := 0;
  OutBuffer.cBuffers := 1;
  OutBuffer.pBuffers := @OutBuffers;

  OutBuffers[0].cbBuffer := sizeof(dwType);
  OutBuffers[0].BufferType := SECBUFFER_TOKEN;
  OutBuffers[0].pvBuffer := @dwType;

  FStatusCode := FunctionTable.ApplyControlToken(@FCtxtHandle, @OutBuffer);
  CheckSspiError(FStatusCode);


  OutBuffers[0].pvBuffer   := nil;
  OutBuffers[0].BufferType := SECBUFFER_TOKEN;
  OutBuffers[0].cbBuffer   := 0;

  OutBuffer.cBuffers       := 1;
  OutBuffer.pBuffers       := @OutBuffers;
  OutBuffer.ulVersion      := SECBUFFER_VERSION;

  try
    FStatusCode := FunctionTable.AcceptSecurityContext(
           @FCredHandle,
           @FCtxtHandle,
           nil,
           dwSSPIFlags,
           0,
           nil,
           @OutBuffer,
           @dwSSPIOutFlags,
           @tsExpiry
      );

    Result := CheckSspiError(FStatusCode);

    if ((OutBuffers[0].pvBuffer <> nil) and (OutBuffers[0].cbBuffer <> 0)) then
    begin
      ABuffer.Size := 0;
      ABuffer.Write(OutBuffers[0].pvBuffer^, OutBuffers[0].cbBuffer);
      ABuffer.Position := 0;
      Result := rcCompleteNeeded;
    end;
  finally
    if (OutBuffers[0].pvBuffer <> nil) then
    begin
      FunctionTable.FreeContextBuffer(OutBuffers[0].pvBuffer);
    end;
    DeleteContext();
    DeleteCredentials();
  end;
end;

function TclTlsServerSspi.GenContext(ABuffer: TStream; ACertificate: TclCertificate;
  AllowEmptyCred: Boolean): TclSspiReturnCode;
var
  InBuffer: TSecBufferDesc;
  InBuffers: array[0..1] of TSecBuffer;
  OutBuffer: TSecBufferDesc;
  OutBuffers: array[0..1] of TSecBuffer;
  dwSSPIFlags, dwSSPIOutFlags: DWORD;
  tsExpiry: TTimeStamp;
  pCtxt: PCtxtHandle;
  secData: TSChannel_Cred;
  buf: PChar;
begin
  ZeroMemory(@secData, Sizeof(secData));
  secData.dwVersion := SCHANNEL_CRED_VERSION;
  secData.dwFlags := 0;

  secData.grbitEnabledProtocols := 0;
  if (tfUseSSL2 in TLSFlags) then
  begin
    secData.grbitEnabledProtocols := secData.grbitEnabledProtocols or SP_PROT_SSL2_SERVER;
  end;
  if (tfUseSSL3 in TLSFlags) then
  begin
    secData.grbitEnabledProtocols := secData.grbitEnabledProtocols or SP_PROT_SSL3_SERVER;
  end;
  if (tfUseTLS in TLSFlags) then
  begin
    secData.grbitEnabledProtocols := secData.grbitEnabledProtocols or SP_PROT_TLS1_SERVER;
  end;

  if FNewConversation then
  begin
    if not GenCredentials(ACertificate, AllowEmptyCred, secData, SECPKG_CRED_INBOUND) then
    begin
      Result := rcCredentialNeeded;
      Exit;
    end;
  end;

  OutBuffer.ulVersion := SECBUFFER_VERSION;
  OutBuffer.cBuffers := 1;
  OutBuffer.pBuffers := @OutBuffers;

  OutBuffers[0].cbBuffer := 0;
  OutBuffers[0].BufferType := SECBUFFER_TOKEN;
  OutBuffers[0].pvBuffer := nil;

  buf := nil;
  try
    FStatusCode := SEC_I_CONTINUE_NEEDED;

    dwSSPIFlags := ASC_REQ_SEQUENCE_DETECT + ASC_REQ_REPLAY_DETECT +
        ASC_REQ_CONFIDENTIALITY + ASC_REQ_EXTENDED_ERROR +
        ASC_REQ_ALLOCATE_MEMORY + ASC_REQ_STREAM;

    if FRequireClientCertificate then
    begin
      dwSSPIFlags := dwSSPIFlags + ASC_REQ_MUTUAL_AUTH;
    end;

    InBuffer.ulVersion := 0;
    InBuffer.cBuffers := 1;
    InBuffer.pBuffers := @InBuffers;

    if (ABuffer.Size > 0) then
    begin
      GetMem(buf, ABuffer.Size);
      ABuffer.Position := 0;
      ABuffer.Read(buf^, ABuffer.Size);
    end;

    InBuffers[0].cbBuffer := ABuffer.Size;
    InBuffers[0].BufferType := SECBUFFER_TOKEN;
    InBuffers[0].pvBuffer := buf;

    pCtxt := nil;
    if not FNewConversation then
    begin
      pCtxt := @FCtxtHandle;
    end;

    FStatusCode := FunctionTable.AcceptSecurityContext(
           @FCredHandle,
           pCtxt,
           @InBuffer,
           dwSSPIFlags,
           0,
           @FCtxtHandle,
           @OutBuffer,
           @dwSSPIOutFlags,
           @tsExpiry
      );

    CheckSspiError(FStatusCode);

    if (FStatusCode = SEC_I_COMPLETE_NEEDED)
        or (FStatusCode = SEC_I_COMPLETE_AND_CONTINUE) then
    begin
      FStatusCode := FunctionTable.CompleteAuthToken(@FCtxtHandle, @OutBuffer);
      CheckSspiError(FStatusCode);
    end;

    ABuffer.Size := 0;
    ABuffer.Write(OutBuffers[0].pvBuffer^, OutBuffers[0].cbBuffer);
    ABuffer.Position := 0;
  finally
    if (OutBuffers[0].pvBuffer <> nil) then
    begin
      FunctionTable.FreeContextBuffer(OutBuffers[0].pvBuffer);
    end;
    FreeMem(buf);
  end;
  FNewConversation := False;

	if (SEC_I_CONTINUE_NEEDED = FStatusCode)
    or (SEC_I_COMPLETE_AND_CONTINUE = FStatusCode) then
  begin
    Result := rcAuthContinueNeeded;
  end else
  begin
    Result := rcOk;
    if FRequireClientCertificate and (not FCertified) then
    begin
      GetClientCertificate();
    end;
    FCertified := True;
  end;
end;

procedure TclTlsServerSspi.GetClientCertificate;
var
  remoteCertContext: PCCERT_CONTEXT;
begin
  FreePeerCertificate();
  remoteCertContext := nil;
  FStatusCode := FunctionTable.QueryContextAttributes(@FCtxtHandle,
                                  SECPKG_ATTR_REMOTE_CERT_CONTEXT,
                                  @remoteCertContext);
  try
    CheckSspiError(FStatusCode);
    FPeer