clsspi.pas

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

  begin
    Inc(ind);
    FDLLHandle := LoadLibrary(DLL_NAMES[ind]);
    if (FDLLHandle <= HINSTANCE_ERROR) then
    begin
      Inc(ind);
      FDLLHandle := LoadLibrary(DLL_NAMES[ind]);
      SetSspiErrorIf(FDLLHandle <= HINSTANCE_ERROR, SSPI_E_LoadLibrary);
    end;
  end;
  InitSecurityInterface := GetProcAddress(FDLLHandle, SECURITY_ENTRYPOINT);
  SetSspiErrorIf(InitSecurityInterface = nil, SSPI_E_FuncTableInit);

  FFunctionTable := TInitSecurityInterface(InitSecurityInterface);
  SetSspiErrorIf(FFunctionTable = nil, SSPI_E_SecPackage);
end;

{ TclTlsClientSspi }

constructor TclTlsClientSspi.Create(const ATargetName: string);
begin
  inherited Create();
  FTargetName := ATargetName;
  if (FTargetName = '') then
  begin
    FTargetName := FloatToStr(Now);
  end;
  FCertified := False;
end;

function TclTlsClientSspi.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 := ISC_REQ_SEQUENCE_DETECT + ISC_REQ_REPLAY_DETECT +
      ISC_REQ_CONFIDENTIALITY + ISC_REQ_EXTENDED_ERROR +
      ISC_REQ_ALLOCATE_MEMORY + ISC_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.InitializeSecurityContext(
                  @FCredHandle,
                  @FCtxtHandle,
                  nil,
                  dwSSPIFlags,
                  0,
                  0,
                  nil,
                  0,
                  @FCtxtHandle,
                  @OutBuffer,
                  @dwSSPIOutFlags,
                  @tsExpiry);

{$IFDEF LOGGER}
    clPutLogMessage(Self, edInside, 'InitializeSecurityContext');
{$ENDIF}

    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 TclTlsClientSspi.GenContext(ABuffer: TStream; ACertificate: TclCertificate;
  AllowEmptyCred: Boolean): TclSspiReturnCode;
var
  secData: TSChannel_Cred;
begin
  ZeroMemory(@secData, Sizeof(secData));
  secData.dwVersion := SCHANNEL_CRED_VERSION;
  secData.dwFlags :=  SCH_CRED_MANUAL_CRED_VALIDATION + SCH_CRED_NO_DEFAULT_CREDS;

  secData.grbitEnabledProtocols := 0;
  if (tfUseSSL2 in TLSFlags) then
  begin
    secData.grbitEnabledProtocols := secData.grbitEnabledProtocols or SP_PROT_SSL2_CLIENT;
  end;
  if (tfUseSSL3 in TLSFlags) then
  begin
    secData.grbitEnabledProtocols := secData.grbitEnabledProtocols or SP_PROT_SSL3_CLIENT;
  end;
  if (tfUseTLS in TLSFlags) then
  begin
    secData.grbitEnabledProtocols := secData.grbitEnabledProtocols or SP_PROT_TLS1_CLIENT;
  end;

  if (FStatusCode = SEC_I_INCOMPLETE_CREDENTIALS) then
  begin
    if not GenCredentials(ACertificate, AllowEmptyCred, secData, SECPKG_CRED_OUTBOUND) then
    begin
      Result := rcCredentialNeeded;
      Exit;
    end;
  end;
  
  FStatusCode := SEC_I_CONTINUE_NEEDED;
  
  if FNewConversation then
  begin
    FNewConversation := False;
    Result := NewConversation(secData, ABuffer);
  end else
  begin
    Result := ContinueConversation(secData, ABuffer, ACertificate, AllowEmptyCred);
  end;

  if not FCertified and (Result in [rcOK, rcEncodeNeeded]) then
  begin
    FCertified := VerifyServerCertificate();
  end;
end;

function TclTlsClientSspi.NewConversation(ASecData: TSChannel_Cred; ABuffer: TStream): TclSspiReturnCode;
var
  OutBuffer: TSecBufferDesc;
  OutBuffers: array[0..1] of TSecBuffer;
  dwSSPIFlags, dwSSPIOutFlags: DWORD;
  tsExpiry: TTimeStamp;
begin
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'NewConversation');{$ENDIF}

  dwSSPIFlags := ISC_REQ_SEQUENCE_DETECT + ISC_REQ_REPLAY_DETECT +
      ISC_REQ_CONFIDENTIALITY + ISC_REQ_EXTENDED_ERROR +
      ISC_REQ_ALLOCATE_MEMORY + ISC_REQ_STREAM;

  DeleteCredentials();
  FStatusCode := FunctionTable.AcquireCredentialsHandle(
      nil,                   // use the default principal
      PChar(GetPackageName()),
      SECPKG_CRED_OUTBOUND,
      nil,                   // use the default LOGON id
      @ASecData,
      nil,                   // no callback function needed to get a key
      nil,                   // no callback function arguments needed
      @FCredHandle,
      @tsExpiry);

{$IFDEF LOGGER}
   clPutLogMessage(Self, edInside, 'AcquireCredentialsHandle');
{$ENDIF}

  SetSspiErrorIf(FStatusCode, SSPI_E_AcquireFailed);

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

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

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

{$IFDEF LOGGER}
    clPutLogMessage(Self, edInside, 'InitializeSecurityContext');
{$ENDIF}

    CheckSspiError(FStatusCode);

    ABuffer.Size := 0;
    ABuffer.Write(OutBuffers[0].pvBuffer^, OutBuffers[0].cbBuffer);
    ABuffer.Position := 0;
{$IFDEF LOGGER}
    clPutLogMessage(Self, edInside, 'NewConversation, OutBuffers[0].pvBuffer', OutBuffers[0].pvBuffer, OutBuffers[0].cbBuffer);
    clPutLogMessage(Self, edInside, 'NewConversation, after InitializeSecurityContext dwSSPIOutFlags = $%x', nil, [dwSSPIOutFlags]);
{$ENDIF}

    Result := rcAuthContinueNeeded;
  finally
    if (OutBuffers[0].pvBuffer <> nil) then
    begin
      FunctionTable.FreeContextBuffer(OutBuffers[0].pvBuffer);
    end;
  end;
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'NewConversation'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'NewConversation', E); raise; end; end;{$ENDIF}
end;

function TclTlsClientSspi.ContinueConversation(ASecData: TSChannel_Cred;
  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;
  NeedToRead: Boolean;
  buf: PChar;
  size: Integer;
begin
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'ContinueConversation');{$ENDIF}
{$IFDEF LOGGER}
  clPutLogMessage(Self, edInside, 'ContinueConversation, ABuffer.Position = %d, ABuffer.Size = %d', nil, [ABuffer.Position, ABuffer.Size]);
{$ENDIF}

  NeedToRead := False;
  Result := rcError;

  dwSSPIFlags := ISC_REQ_SEQUENCE_DETECT + ISC_REQ_REPLAY_DETECT +
      ISC_REQ_CONFIDENTIALITY + ISC_REQ_EXTENDED_ERROR +
      ISC_REQ_ALLOCATE_MEMORY + ISC_REQ_STREAM;

  buf := nil;
  try
    while ((FStatusCode = SEC_I_CONTINUE_NEEDED)
        or (FStatusCode = SEC_E_INCOMPLETE_MESSAGE)
        or (FStatusCode = SEC_I_INCOMPLETE_CREDENTIALS)) do
    begin
{$IFDEF LOGGER}
      clPutLogMessage(Self, edInside, 'ContinueConversation, under while FStatusCode = $%x', nil, [Integer(FStatusCode)]);
{$ENDIF}

      if (ABuffer.Size = 0) or (FStatusCode = SEC_E_INCOMPLETE_MESSAGE) then
      begin
        if NeedToRead then
        begin
          Result := rcAuthMoreDataNeeded;
          Break;
        end else
        begin
          NeedToRead := True;
        end;
      end;

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

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

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

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

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

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

{$IFDEF LOGGER}
      clPutLogMessage(Self, edInside, 'ContinueConversation, InBuffers[0].pvBuffer', InBuffers[0].pvBuffer, InBuffers[0].cbBuffer);
{$ENDIF}

      InBuffers[1].cbBuffer := 0;
      InBuffers[1].BufferType := SECBUFFER_EMPTY;
      InBuffers[1].pvBuffer := nil;

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

{$IFDEF LOGGER}
      clPutLogMessage(Self, edInside, 'InitializeSecurityContext');

      clPutLogMessage(Self, edInside, 'ContinueConversation, after InitializeSecurityContext FStatusCode = $%x', nil, [Integer(FStatusCode)]);
      clPutLogMessage(Self, edInside, 'ContinueConversation, OutBuffers[0].pvBuffer', OutBuffers[0].pvBuffer, OutBuffers[0].cbBuffer);

      if (InBuffers[1].BufferType = SECBUFFER_EXTRA) then
      begin
        clPutLogMessage(Self, edInside, 'ContinueConversation, InBuffers[1] = SECBUFFER_EXTRA (' + IntToStr(InBuffers[1].cbBuffer));
      end else
      begin
        clPutLogMessage(Self, edInside, 'ContinueConversation, InBuffers[1] = no extra data');
      end;
      
      clPutLogMessage(Self, edInside, 'ContinueConversation, after InitializeSecurityContext dwSSPIOutFlags = $%x', nil, [dwSSPIOutFlags]);
{$ENDIF}

      if (FStatusCode = SEC_E_OK) or (FStatusCode = SEC_I_CONTINUE_NEEDED)
        or (FAILED(FStatusCode) and ((dwSSPIOutFlags and ISC_RET_EXTENDED_ERROR) <> 0)) then
      begin
        if (OutBuffers[0].cbBuffer <> 0) and (OutBuffers[0].pvBuffer <> nil) then
        begin
          ABuffer.Size := 0;
          ABuffer.Write(OutBuffers[0].pvBuffer^, OutBuffers[0].cbBuffer);
          ABuffer.Position := 0;

          FunctionTable.FreeContextBuffer(OutBuffers[0].pvBuffer);
          OutBuffers[0].pvBuffer := nil;

          Result := rcAuthContinueNeeded;
{$IFDEF LOGGER}
  clPutLogMessage(Self, edInside, 'ContinueConversation, inside if (FStatusCode = SEC_E_OK) or..., ABuffer.Position = %d, ABuffer.Size = %d', nil, [ABuffer.Position, ABuffer.Size]);
{$ENDIF}
          Break;
        end;
      end;
      if (FStatusCode = SEC_E_INCOMPLETE_MESSAGE) then
      begin