www.pudn.com > Indy_9_00_14_src.zip > IdAuthenticationSSPI.pas

{ $HDR$} 
{**********************************************************************} 
{ Unit archived using Team Coherence                                   } 
{ Team Coherence is Copyright 2002 by Quality Software Components      } 
{                                                                      } 
{ For further information / comments, visit our WEB site at            } 
{ http://www.TeamCoherence.com                                         } 
{**********************************************************************} 
{} 
{ $Log:  10079: IdAuthenticationSSPI.pas  
{ 
{   Rev 1.1    01.2.2003 ã. 11:54:16  DBondzhev 
} 
{ 
{   Rev 1.0    2002.11.12 10:31:20 PM  czhower 
} 
{ 
 
  Implementation of the NTLM authentication with SSPI 
 
  Author: Alex Brainman 
  Copyright: (c) Chad Z. Hower and The Winshoes Working Group. 
 
} 
 
unit IdAuthenticationSSPI; 
{$DEFINE SET_ENCRYPT_IN_FT_WITH_GETPROCADDRESS_FUDGE} 
 
interface 
 
uses 
  IdAuthentication, Windows, classes, SysUtils, 
  IdSSPI; 
 
const 
  SEC_E_OK                         = 0; 
  SEC_E_INSUFFICIENT_MEMORY        = HRESULT($80090300); 
  SEC_E_INVALID_HANDLE             = HRESULT($80090301); 
  SEC_E_UNSUPPORTED_FUNCTION       = HRESULT($80090302); 
  SEC_E_TARGET_UNKNOWN             = HRESULT($80090303); 
  SEC_E_INTERNAL_ERROR             = HRESULT($80090304); 
  SEC_E_SECPKG_NOT_FOUND           = HRESULT($80090305); 
  SEC_E_NOT_OWNER                  = HRESULT($80090306); 
  SEC_E_CANNOT_INSTALL             = HRESULT($80090307); 
  SEC_E_INVALID_TOKEN              = HRESULT($80090308); 
  SEC_E_CANNOT_PACK                = HRESULT($80090309); 
  SEC_E_QOP_NOT_SUPPORTED          = HRESULT($8009030A); 
  SEC_E_NO_IMPERSONATION           = HRESULT($8009030B); 
  SEC_E_LOGON_DENIED               = HRESULT($8009030C); 
  SEC_E_UNKNOWN_CREDENTIALS        = HRESULT($8009030D); 
  SEC_E_NO_CREDENTIALS             = HRESULT($8009030E); 
  SEC_E_MESSAGE_ALTERED            = HRESULT($8009030F); 
  SEC_E_OUT_OF_SEQUENCE            = HRESULT($80090310); 
  SEC_E_NO_AUTHENTICATING_AUTHORITY = HRESULT($80090311); 
  SEC_I_CONTINUE_NEEDED            = HRESULT($00090312); 
  SEC_I_COMPLETE_NEEDED            = HRESULT($00090313); 
  SEC_I_COMPLETE_AND_CONTINUE      = HRESULT($00090314); 
  SEC_I_LOCAL_LOGON                = HRESULT($00090315); 
  SEC_E_BAD_PKGID                  = HRESULT($80090316); 
  SEC_E_CONTEXT_EXPIRED            = HRESULT($80090317); 
  SEC_E_INCOMPLETE_MESSAGE         = HRESULT($80090318); 
  SEC_E_INCOMPLETE_CREDENTIALS     = HRESULT($80090320); 
  SEC_E_BUFFER_TOO_SMALL           = HRESULT($80090321); 
  SEC_I_INCOMPLETE_CREDENTIALS     = HRESULT($00090320); 
  SEC_I_RENEGOTIATE                = HRESULT($00090321); 
  SEC_E_WRONG_PRINCIPAL            = HRESULT($80090322); 
  SEC_I_NO_LSA_CONTEXT             = HRESULT($00090323); 
  SEC_E_TIME_SKEW                  = HRESULT($80090324); 
  SEC_E_UNTRUSTED_ROOT             = HRESULT($80090325); 
  SEC_E_ILLEGAL_MESSAGE            = HRESULT($80090326); 
  SEC_E_CERT_UNKNOWN               = HRESULT($80090327); 
  SEC_E_CERT_EXPIRED               = HRESULT($80090328); 
  SEC_E_ENCRYPT_FAILURE            = HRESULT($80090329); 
  SEC_E_DECRYPT_FAILURE            = HRESULT($80090330); 
  SEC_E_ALGORITHM_MISMATCH         = HRESULT($80090331); 
  SEC_E_SECURITY_QOS_FAILED        = HRESULT($80090332); 
 
type 
  { ESSPIException } 
  ESSPIException = class(Exception) 
  public 
    class function GetErrorMessageByNo(aErrorNo: LongWord): string; 
  public 
    constructor CreateError( 
      aFailedFuncName: string; anErrorNo: Longint = SEC_E_OK); 
  end; 
 
  ESSPIInterfaceInitFailed = class(ESSPIException); 
 
  { TSSPIInterface } 
 
  TSSPIInterface = class(TObject) 
  private 
    fLoadPending, fIsAvailable: Boolean; 
    fPFunctionTable: PSecurityFunctionTableA; 
    fDLLHandle: THandle; 
    procedure releaseFunctionTable; 
    procedure checkAvailable; 
    function getFunctionTable: SecurityFunctionTableA; 
  public 
    class procedure RaiseIfError( 
      aStatus: SECURITY_STATUS; aFunctionName: string); 
    function IsAvailable: Boolean; 
    property FunctionTable: SecurityFunctionTableA read getFunctionTable; 
  public 
    constructor Create; 
    destructor Destroy; override; 
  end; 
 
  { TSSPIPackages } 
 
  TSSPIPackage = class(TObject) 
  private 
    fPSecPkginfo: PSecPkgInfo; 
    function getPSecPkgInfo: PSecPkgInfo; 
    function getMaxToken: ULONG; 
    function getName: string; 
  public 
    property MaxToken: ULONG read getMaxToken; 
    property Name: string read getName; 
  public 
    constructor Create(aPSecPkginfo: PSecPkgInfo); 
  end; 
 
  TCustomSSPIPackage = class(TSSPIPackage) 
  private 
    fInfo: PSecPkgInfo; 
  public 
    constructor Create(aPkgName: string); 
    destructor Destroy; override; 
  end; 
 
  TSSPINTLMPackage = class(TCustomSSPIPackage) 
  public 
    constructor Create; 
  end; 
 
  { TSSPICredentials } 
 
  TSSPICredentialsUse = (scuInBound, scuOutBound, scuBoth); 
 
  TSSPICredentials = class(TObject) 
  private 
    fPackage: TSSPIPackage; 
    fHandle: CredHandle; 
    fUse: TSSPICredentialsUse; 
    fAcquired: Boolean; 
    fExpiry: TimeStamp; 
    function getHandle: PCredHandle; 
    procedure setUse(aValue: TSSPICredentialsUse); 
  protected 
    procedure CheckAcquired; 
    procedure CheckNotAcquired; 
    procedure DoAcquire(pszPrincipal: PSEC_CHAR; pvLogonId, pAuthData: PVOID); 
    procedure DoRelease; virtual; 
  public 
    procedure Release; 
    property Package: TSSPIPackage read fPackage; 
    property Handle: PCredHandle read getHandle; 
    property Use: TSSPICredentialsUse read fUse write setUse; 
    property Acquired: Boolean read fAcquired; 
  public 
    constructor Create(aPackage: TSSPIPackage); 
    destructor Destroy; override; 
 
  end; 
 
  { TSSPIWinNTCredentials } 
 
  TSSPIWinNTCredentials = class(TSSPICredentials) 
  protected 
  public 
    procedure Acquire( 
      aUse: TSSPICredentialsUse); overload; 
    procedure Acquire( 
      aUse: TSSPICredentialsUse; aDomain, 
      aUserName, aPassword: string); overload; 
  end; 
 
  { TSSPIContext } 
 
  TSSPIContext = class(TObject) 
 
  private 
    fCredentials: TSSPICredentials; 
    fHandle: CtxtHandle; 
    fHasHandle: Boolean; 
    fExpiry: TimeStamp; 
    function getHandle: PCtxtHandle; 
    function getExpiry: TimeStamp; 
    procedure updateHasContextAndCheckForError( 
      const aFuncResult: SECURITY_STATUS; const aFuncName: string; 
      const aErrorsToIgnore: array of SECURITY_STATUS); 
  protected 
    procedure CheckHasHandle; 
    procedure CheckCredentials; 
    function DoInitialize( 
      aTokenSourceName: PChar; 
      var aIn, aOut: SecBufferDesc; 
      const errorsToIgnore: array of SECURITY_STATUS): SECURITY_STATUS; 
    procedure DoRelease; virtual; 
    function GetRequestedFlags: ULONG; virtual; abstract; 
    procedure SetEstablishedFlags(aFlags: ULONG); virtual; abstract; 
    function GetAuthenticated: Boolean; virtual; abstract; 
    property HasHandle: Boolean read fHasHandle; 
  public 
    procedure Release; 
    property Credentials: TSSPICredentials read fCredentials; 
    property Handle: PCtxtHandle read getHandle; 
    property Authenticated: Boolean read GetAuthenticated; 
    property Expiry: TimeStamp read getExpiry; 
  public 
    constructor Create(aCredentials: TSSPICredentials); 
    destructor Destroy; override; 
 
  end; 
 
  { TSSPIConnectionContext } 
 
  TCustomSSPIConnectionContext = class(TSSPIContext) 
 
  private 
    fStatus: SECURITY_STATUS; 
    fOutBuffDesc, fInBuffDesc: SecBufferDesc; 
    fInBuff: SecBuffer; 
  protected 
    procedure DoRelease; override; 
    function GetAuthenticated: Boolean; override; 
    function DoUpdateAndGenerateReply( 
      var aIn, aOut: SecBufferDesc; 
      const aErrorsToIgnore: array of SECURITY_STATUS 
      ): SECURITY_STATUS; virtual; abstract; 
  public 
    function UpdateAndGenerateReply( 
      const aFromPeerToken: string; var aToPeerToken: string): Boolean; 
 
  public 
    constructor Create(aCredentials: TSSPICredentials); 
 
  end; 
 
  TSSPIClientConnectionContext = class(TCustomSSPIConnectionContext) 
  private 
    fTargetName: string; 
    fReqReguested, fReqEstablished: ULONG; 
  protected 
    function GetRequestedFlags: ULONG; override; 
    procedure SetEstablishedFlags(aFlags: ULONG); override; 
    function DoUpdateAndGenerateReply( 
      var aIn, aOut: SecBufferDesc; 
      const aErrorsToIgnore: array of SECURITY_STATUS 
      ): SECURITY_STATUS; override; 
  public 
    function GenerateInitialChalenge( 
      const aTargetName: string; var aToPeerToken: string): Boolean; 
  public 
    constructor Create(aCredentials: TSSPICredentials); 
  end; 
 
  TIndySSPINTLMClient = class(TObject) 
  protected 
    fNTLMPackage: TSSPINTLMPackage; 
    fCredentials: TSSPIWinNTCredentials; 
    fContext: TSSPIClientConnectionContext; 
  public 
    procedure SetCredentials(aDomain, aUserName, aPassword: string); 
    procedure SetCredentialsAsCurrentUser; 
    function InitAndBuildType1Message: string; 
    function UpdateAndBuildType3Message(aServerType2Message: string): string; 
  public 
    constructor Create; 
    destructor Destroy; override; 
  end; 
 
  TIdSSPINTLMAuthentication = class(TIdAuthentication) 
  protected 
    FNTLMInfo: string; 
    FSSPIClient: TIndySSPINTLMClient; 
 
    function GetSteps: Integer; override; 
    function DoNext: TIdAuthWhatsNext; override; 
  public 
    constructor Create; override; 
    function Authentication: string; override; 
    function KeepAlive: Boolean; override; 
    procedure Reset; override; 
  end; 
 
implementation 
 
uses 
  IdGlobal, 
  IdException, 
  IdCoderMIME, 
  IdResourceStrings, Math; 
 
var 
  g: TSSPIInterface; 
 
{ ESSPIException } 
 
class function ESSPIException.GetErrorMessageByNo 
  (aErrorNo: LongWord): string; 
begin 
  case HRESULT(aErrorNo) of 
    SEC_E_OK: Result := RSHTTPSSPISuccess; 
    SEC_E_INSUFFICIENT_MEMORY: 
      Result := RSHTTPSSPINotEnoughMem; 
    SEC_E_INVALID_HANDLE: 
      Result := RSHTTPSSPIInvalidHandle; 
    SEC_E_UNSUPPORTED_FUNCTION: 
      Result := RSHTTPSSPIFuncNotSupported; 
    SEC_E_TARGET_UNKNOWN: 
      Result := RSHTTPSSPIUnknownTarget; 
    SEC_E_INTERNAL_ERROR: 
      Result := RSHTTPSSPIInternalError; 
    SEC_E_SECPKG_NOT_FOUND: 
      Result :=  RSHTTPSSPISecPackageNotFound; 
    SEC_E_NOT_OWNER: 
      Result := RSHTTPSSPINotOwner; 
    SEC_E_CANNOT_INSTALL: 
      Result := RSHTTPSSPIPackageCannotBeInstalled; 
    SEC_E_INVALID_TOKEN: 
      Result := RSHTTPSSPIInvalidToken; 
    SEC_E_CANNOT_PACK: 
      Result := RSHTTPSSPICannotPack; 
    SEC_E_QOP_NOT_SUPPORTED: 
      Result := RSHTTPSSPIQOPNotSupported; 
    SEC_E_NO_IMPERSONATION: 
      Result := RSHTTPSSPINoImpersonation; 
    SEC_E_LOGON_DENIED: 
      Result := RSHTTPSSPILoginDenied; 
    SEC_E_UNKNOWN_CREDENTIALS: 
      Result := RSHTTPSSPIUnknownCredentials; 
    SEC_E_NO_CREDENTIALS: 
      Result := RSHTTPSSPINoCredentials; 
    SEC_E_MESSAGE_ALTERED: 
      Result := RSHTTPSSPIMessageAltered; 
    SEC_E_OUT_OF_SEQUENCE: 
      Result := RSHTTPSSPIOutOfSequence; 
    SEC_E_NO_AUTHENTICATING_AUTHORITY: 
      Result := RSHTTPSSPINoAuthAuthority; 
    SEC_I_CONTINUE_NEEDED: 
      Result := RSHTTPSSPIContinueNeeded; 
    SEC_I_COMPLETE_NEEDED: 
      Result := RSHTTPSSPICompleteNeeded; 
    SEC_I_COMPLETE_AND_CONTINUE: 
      Result :=RSHTTPSSPICompleteContinueNeeded; 
    SEC_I_LOCAL_LOGON: 
      Result := RSHTTPSSPILocalLogin; 
    SEC_E_BAD_PKGID: 
      Result := RSHTTPSSPIBadPackageID; 
    SEC_E_CONTEXT_EXPIRED: 
      Result := RSHTTPSSPIContextExpired; 
    SEC_E_INCOMPLETE_MESSAGE: 
      Result := RSHTTPSSPIIncompleteMessage; 
    SEC_E_INCOMPLETE_CREDENTIALS: 
      Result := RSHTTPSSPIIncompleteCredentialNotInit; 
    SEC_E_BUFFER_TOO_SMALL: 
      Result := RSHTTPSSPIBufferTooSmall; 
 
    SEC_I_INCOMPLETE_CREDENTIALS: 
      Result := RSHTTPSSPIIncompleteCredentialsInit; 
    SEC_I_RENEGOTIATE: 
      Result := RSHTTPSSPIRengotiate; 
    SEC_E_WRONG_PRINCIPAL: 
      Result := RSHTTPSSPIWrongPrincipal; 
    SEC_I_NO_LSA_CONTEXT: 
      Result := RSHTTPSSPINoLSACode; 
    SEC_E_TIME_SKEW: 
      Result := RSHTTPSSPITimeScew; 
    SEC_E_UNTRUSTED_ROOT: 
      Result := RSHTTPSSPIUntrustedRoot; 
    SEC_E_ILLEGAL_MESSAGE: 
      Result := RSHTTPSSPIIllegalMessage; 
    SEC_E_CERT_UNKNOWN: 
      Result := RSHTTPSSPICertUnknown; 
    SEC_E_CERT_EXPIRED: 
      Result := RSHTTPSSPICertExpired; 
    SEC_E_ENCRYPT_FAILURE: 
      Result := RSHTTPSSPIEncryptionFailure; 
    SEC_E_DECRYPT_FAILURE: 
      Result := RSHTTPSSPIDecryptionFailure; 
    SEC_E_ALGORITHM_MISMATCH: 
      Result := RSHTTPSSPIAlgorithmMismatch; 
    SEC_E_SECURITY_QOS_FAILED: 
      Result := RSHTTPSSPISecurityQOSFailure; 
  else 
    Result := RSHTTPSSPIUnknwonError; 
  end; 
end; 
 
constructor ESSPIException.CreateError 
  (aFailedFuncName: string; anErrorNo: Longint = SEC_E_OK); 
begin 
  if anErrorNo = SEC_E_OK then 
    inherited Create(aFailedFuncName) 
  else 
    inherited CreateFmt( 
      RSHTTPSSPIErrorMsg, 
      [aFailedFuncName, anErrorNo, anErrorNo, GetErrorMessageByNo(anErrorNo)]); 
end; 
 
{ TSSPIInterface } 
 
procedure TSSPIInterface.releaseFunctionTable; 
begin 
  if fPFunctionTable <> nil then begin 
    fPFunctionTable := nil; 
  end; 
end; 
 
procedure TSSPIInterface.checkAvailable; 
begin 
  if not IsAvailable then 
    raise ESSPIInterfaceInitFailed.Create( 
      RSHTTPSSPIInterfaceInitFailed); 
end; 
 
function TSSPIInterface.getFunctionTable: SecurityFunctionTableA; 
begin 
  checkAvailable; 
  Result := fPFunctionTable^; 
end; 
 
class procedure TSSPIInterface.RaiseIfError 
  (aStatus: SECURITY_STATUS; aFunctionName: string); 
begin 
  if not SEC_SUCCESS(aStatus) then 
    raise ESSPIException.CreateError(aFunctionName, aStatus); 
end; 
 
function TSSPIInterface.IsAvailable: Boolean; 
 
  procedure loadDLL; 
  const 
    SECURITY_DLL_NT = 'security.dll';    {Do not translate} 
    SECURITY_DLL_95 = 'secur32.dll';   {Do not translate} 
    ENCRYPT_MESSAGE = 'EncryptMessage';   {Do not translate} 
    DECRYPT_MESSAGE = 'DecryptMessage';    {Do not translate} 
  var 
    dllName: string; 
    entrypoint: INIT_SECURITY_INTERFACE_A; 
  begin 
    fIsAvailable := False; 
    if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then 
      { Windows95 SSPI dll } 
      dllName := SECURITY_DLL_95 
    else 
      { WindowsNT & Windows2000 SSPI dll } 
      dllName := SECURITY_DLL_NT; 
    { load SSPI dll } 
    fDLLHandle := LoadLibrary(@dllName[1]); 
    if fDLLHandle > 0 then begin 
      { get InitSecurityInterface entry point 
        and call it to fetch SPPI function table} 
      entrypoint := GetProcAddress(fDLLHandle, SECURITY_ENTRYPOINTA); 
      fPFunctionTable := entrypoint; 
      { let's see what SSPI functions are available 
        and if we can continue on with the set } 
      with fPFunctionTable^ do begin 
        fIsAvailable := 
          Assigned(QuerySecurityPackageInfoA) and 
          Assigned(FreeContextBuffer) and 
          Assigned(DeleteSecurityContext) and 
          Assigned(FreeCredentialHandle) and 
          Assigned(AcquireCredentialsHandleA) and 
          Assigned(InitializeSecurityContextA) and 
        Assigned(AcceptSecurityContext) and 
          Assigned(ImpersonateSecurityContext) and 
          Assigned(RevertSecurityContext) and 
          Assigned(QueryContextAttributesA) and 
          Assigned(MakeSignature) and 
          Assigned(VerifySignature); 
{$IFDEF SET_ENCRYPT_IN_FT_WITH_GETPROCADDRESS_FUDGE} 
        { fudge for Encrypt/DecryptMessage } 
        if (not Assigned(EncryptMessage)) and (GetProcAddress(fDLLHandle, ENCRYPT_MESSAGE) <> nil) then 
          EncryptMessage := GetProcAddress(fDLLHandle, ENCRYPT_MESSAGE); 
        if (not Assigned(DecryptMessage)) and (GetProcAddress(fDLLHandle, DECRYPT_MESSAGE) <> nil) then 
          DecryptMessage := GetProcAddress(fDLLHandle, DECRYPT_MESSAGE); 
{$ENDIF} 
      end; 
    end; 
  end; 
 
begin 
  if fIsAvailable then 
    Result := True 
  else begin 
    if fLoadPending then begin 
      releaseFunctionTable; 
      loadDLL; 
      fLoadPending := False; 
    end; 
    Result := fIsAvailable; 
  end; 
end; 
 
constructor TSSPIInterface.Create; 
begin 
  inherited Create; 
  fLoadPending := True; 
  fIsAvailable := False; 
  fPFunctionTable := nil; 
end; 
 
destructor TSSPIInterface.Destroy; 
begin 
  releaseFunctionTable; 
  FreeLibrary(fDLLHandle); 
  inherited Destroy; 
end; 
 
{ TSSPIPackage } 
 
function TSSPIPackage.getPSecPkgInfo: PSecPkgInfo; 
begin 
  if fPSecPkginfo = nil then 
    raise ESSPIException.Create(RSHTTPSSPINoPkgInfoSpecified); 
  Result := fPSecPkginfo; 
end; 
 
function TSSPIPackage.getMaxToken: ULONG; 
begin 
  Result := getPSecPkgInfo^.cbMaxToken; 
end; 
 
function TSSPIPackage.getName: string; 
begin 
  Result := StrPas(getPSecPkgInfo^.Name); 
end; 
 
constructor TSSPIPackage.Create(aPSecPkginfo: PSecPkgInfo); 
begin 
  inherited Create; 
  fPSecPkginfo := aPSecPkginfo; 
end; 
 
{ TCustomSSPIPackage } 
 
constructor TCustomSSPIPackage.Create(aPkgName: string); 
begin 
  g.RaiseIfError( 
    g.FunctionTable.QuerySecurityPackageInfoA(PChar(aPkgName), @fInfo), 
    'QuerySecurityPackageInfoA');   {Do not translate} 
  inherited Create(fInfo); 
end; 
 
destructor TCustomSSPIPackage.Destroy; 
begin 
  if fInfo <> nil then 
    g.RaiseIfError( 
      g.FunctionTable.FreeContextBuffer(fInfo), 'FreeContextBuffer');  {Do not translate} 
  inherited Destroy; 
end; 
 
{ TSSPINTLMPackage } 
 
constructor TSSPINTLMPackage.Create; 
begin 
  inherited Create(NTLMSP_NAME); 
end; 
 
{ TSSPICredentials } 
 
procedure TSSPICredentials.CheckAcquired; 
begin 
  if not fAcquired then 
    raise ESSPIException.Create(RSHTTPSSPINoCredentialHandle); 
end; 
 
procedure TSSPICredentials.CheckNotAcquired; 
begin 
  if fAcquired then 
    raise ESSPIException.Create( 
     RSHTTPSSPICanNotChangeCredentials); 
end; 
 
procedure TSSPICredentials.DoAcquire 
  (pszPrincipal: PSEC_CHAR; pvLogonId, pAuthData: PVOID); 
var 
  cu: ULONG; 
begin 
  Release; 
  case Use of 
    scuInBound: 
      cu := SECPKG_CRED_INBOUND; 
    scuOutBound: 
      cu := SECPKG_CRED_OUTBOUND; 
    scuBoth: 
      cu := SECPKG_CRED_BOTH; 
  else 
    raise ESSPIException.Create(RSHTTPSSPIUnknwonCredentialUse); 
  end; 
  g.RaiseIfError( 
    g.FunctionTable.AcquireCredentialsHandleA( 
    pszPrincipal, PSEC_CHAR(Package.Name), cu, pvLogonId, pAuthData, nil, nil, 
    @fHandle, @fExpiry), 
    'AcquireCredentialsHandleA');  {Do not translater} 
  fAcquired := True; 
end; 
 
procedure TSSPICredentials.DoRelease; 
begin 
  g.RaiseIfError( 
    g.FunctionTable.FreeCredentialHandle(@fHandle), 
    'FreeCredentialHandle');      {Do not translate} 
  SecInvalidateHandle(@fHandle); 
end; 
 
procedure TSSPICredentials.Release; 
begin 
  if fAcquired then begin 
    DoRelease; 
    fAcquired := False; 
  end; 
end; 
 
function TSSPICredentials.getHandle: PCredHandle; 
begin 
  CheckAcquired; 
  Result := @fHandle; 
end; 
 
procedure TSSPICredentials.setUse(aValue: TSSPICredentialsUse); 
begin 
  if fUse <> aValue then begin 
    CheckNotAcquired; 
    fUse := aValue; 
  end; 
end; 
 
constructor TSSPICredentials.Create(aPackage: TSSPIPackage); 
begin 
  inherited Create; 
  fPackage := aPackage; 
  fUse := scuOutBound; 
  fAcquired := False; 
end; 
 
destructor TSSPICredentials.Destroy; 
begin 
  Release; 
  inherited Destroy; 
end; 
 
{ TSSPIWinNTCredentials } 
 
procedure TSSPIWinNTCredentials.Acquire(aUse: TSSPICredentialsUse); 
begin 
  Acquire(aUse, '', '', '');          {Do not translate} 
end; 
 
procedure TSSPIWinNTCredentials.Acquire 
  (aUse: TSSPICredentialsUse; aDomain, aUserName, aPassword: string); 
var 
  ai: SEC_WINNT_AUTH_IDENTITY; 
  pai: PVOID; 
begin 
  Use := aUse; 
  if (Length(aDomain) > 0) and (Length(aUserName) > 0) then begin 
    with ai do begin 
      User := PChar(aUserName); 
      UserLength := Length(aUserName); 
      Domain := PChar(aDomain); 
      DomainLength := Length(aDomain); 
      Password := PChar(aPassword); 
      PasswordLength := Length(aPassword); 
      Flags := SEC_WINNT_AUTH_IDENTITY_ANSI; 
    end; 
    pai := @ai; 
  end else 
    pai := nil; 
  DoAcquire(nil, nil, pai); 
end; 
 
{ TSSPIContext } 
 
constructor TSSPIContext.Create(aCredentials: TSSPICredentials); 
begin 
  inherited Create; 
  fCredentials := aCredentials; 
  fHasHandle := False; 
end; 
 
destructor TSSPIContext.Destroy; 
begin 
  Release; 
  inherited Destroy; 
end; 
 
procedure TSSPIContext.updateHasContextAndCheckForError( 
  const aFuncResult: SECURITY_STATUS; const aFuncName: string; 
  const aErrorsToIgnore: array of SECURITY_STATUS); 
var 
  doRaise: Boolean; 
  i: Integer; 
begin 
  doRaise := not SEC_SUCCESS(aFuncResult); 
  if doRaise then 
    for i := Low(aErrorsToIgnore) to High(aErrorsToIgnore) do 
      if aFuncResult = aErrorsToIgnore[i] then begin 
        doRaise := False; 
        break; 
      end; 
  if doRaise then 
    raise ESSPIException.CreateError(aFuncName, aFuncResult); 
  if not fHasHandle then 
    fHasHandle := True; 
end; 
 
function TSSPIContext.DoInitialize 
  (aTokenSourceName: PChar; 
  var aIn, aOut: SecBufferDesc; 
  const errorsToIgnore: array of SECURITY_STATUS): SECURITY_STATUS; 
var 
  tmp: PCtxtHandle; 
  tmp2: PSecBufferDesc; 
  r: ULONG; 
begin 
  if fHasHandle then begin 
    tmp := @fHandle; 
    tmp2 := @aIn; 
  end else begin 
    tmp := nil; 
    tmp2 := nil; 
  end; 
  Result := 
    g.FunctionTable.InitializeSecurityContextA( 
    Credentials.Handle, tmp, aTokenSourceName, 
    GetRequestedFlags, 0, SECURITY_NATIVE_DREP, tmp2, 0, 
    @fHandle, @aOut, @r, @fExpiry 
    ); 
  updateHasContextAndCheckForError( 
    Result, 'InitializeSecurityContextA', errorsToIgnore); {Do not translate} 
  SetEstablishedFlags(r); 
end; 
 
procedure TSSPIContext.DoRelease; 
begin 
  g.RaiseIfError( 
    g.FunctionTable.DeleteSecurityContext(@fHandle), 'DeleteSecurityContext'); {Do not translate} 
end; 
 
procedure TSSPIContext.Release; 
begin 
  if HasHandle then begin 
    DoRelease; 
    fHasHandle := False; 
  end; 
end; 
 
procedure TSSPIContext.CheckHasHandle; 
begin 
  if not HasHandle then 
    raise ESSPIException.Create(RSHTTPSSPINoCredentialHandle); 
end; 
 
procedure TSSPIContext.CheckCredentials; 
begin 
  if (not Assigned(Credentials)) or (not Credentials.Acquired) then 
    raise ESSPIException.Create(RSHTTPSSPIDoAuquireCredentialHandle); 
end; 
 
function TSSPIContext.getExpiry: TimeStamp; 
begin 
  CheckHasHandle; 
  Result := fExpiry; 
end; 
 
function TSSPIContext.getHandle: PCtxtHandle; 
begin 
  CheckHasHandle; 
  Result := @fHandle; 
end; 
 
{ TCustomSSPIConnectionContext } 
 
procedure TCustomSSPIConnectionContext.DoRelease; 
begin 
  inherited DoRelease; 
  fStatus := SEC_E_INVALID_HANDLE; // just to put something other then SEC_E_OK 
end; 
 
function TCustomSSPIConnectionContext.GetAuthenticated: Boolean; 
begin 
  CheckHasHandle; 
  Result := fStatus = SEC_E_OK; 
end; 
 
function TCustomSSPIConnectionContext.UpdateAndGenerateReply 
  (const aFromPeerToken: string; var aToPeerToken: string): Boolean; 
var 
  fOutBuff: SecBuffer; 
begin 
  Result := False; 
  { check credentials } 
  CheckCredentials; 
  { prepare input buffer } 
  with fInBuff do begin 
    cbBuffer := Length(aFromPeerToken); 
    pvBuffer := @(aFromPeerToken[1]); 
  end; 
  { prepare output buffer } 
  with fOutBuff do begin 
    BufferType := SECBUFFER_TOKEN; 
    cbBuffer := Credentials.Package.MaxToken; 
    pvBuffer := AllocMem(cbBuffer); 
  end; 
  with fOutBuffDesc do begin 
    ulVersion := SECBUFFER_VERSION; 
    cBuffers := 1; 
    pBuffers := @fOutBuff; 
  end; 
  try 
    { do processing } 
    fStatus := DoUpdateAndGenerateReply(fInBuffDesc, fOutBuffDesc, []); 
    { complete token if applicable } 
    case fStatus of 
      SEC_I_COMPLETE_NEEDED, 
        SEC_I_COMPLETE_AND_CONTINUE: 
        begin 
          if not Assigned(g.FunctionTable.CompleteAuthToken) then 
          begin 
            raise ESSPIException.Create(RSHTTPSSPICompleteTokenNotSupported); 
          end; 
          fStatus := g.FunctionTable.CompleteAuthToken(Handle, @fOutBuffDesc); 
          g.RaiseIfError(fStatus, 'CompleteAuthToken');   {Do not translate} 
        end; 
    end; 
    Result := 
      (fStatus = SEC_I_CONTINUE_NEEDED) or 
      (fStatus = SEC_I_COMPLETE_AND_CONTINUE) or 
      (fOutBuff.cbBuffer > 0); 
    if Result then 
      with fOutBuff do 
        SetString(aToPeerToken, PChar(pvBuffer), cbBuffer); 
  finally 
    FreeMem(fOutBuff.pvBuffer); 
  end; 
end; 
 
constructor TCustomSSPIConnectionContext.Create(aCredentials: TSSPICredentials); 
begin 
  inherited Create(aCredentials); 
  with fInBuff do begin 
    BufferType := SECBUFFER_TOKEN; 
  end; 
  with fInBuffDesc do begin 
    ulVersion := SECBUFFER_VERSION; 
    cBuffers := 1; 
    pBuffers := @fInBuff; 
  end; 
  with fOutBuffDesc do begin 
    ulVersion := SECBUFFER_VERSION; 
    cBuffers := 1; 
  end; 
end; 
 
{ TSSPIClientConnectionContext } 
 
constructor TSSPIClientConnectionContext.Create(aCredentials: TSSPICredentials); 
begin 
  inherited Create(aCredentials); 
  fTargetName := '';   {Do not translate} 
end; 
 
function TSSPIClientConnectionContext.GetRequestedFlags: ULONG; 
begin 
  Result := fReqReguested; 
end; 
 
procedure TSSPIClientConnectionContext.SetEstablishedFlags(aFlags: ULONG); 
begin 
  fReqEstablished := aFlags; 
end; 
 
function TSSPIClientConnectionContext.DoUpdateAndGenerateReply 
  (var aIn, aOut: SecBufferDesc; 
  const aErrorsToIgnore: array of SECURITY_STATUS): SECURITY_STATUS; 
begin 
  Result := DoInitialize(PChar(fTargetName), aIn, aOut, []); 
end; 
 
function TSSPIClientConnectionContext.GenerateInitialChalenge 
  (const aTargetName: string; var aToPeerToken: string): Boolean; 
begin 
  Release; 
  fTargetName := aTargetName; 
  Result := UpdateAndGenerateReply('', aToPeerToken);   {Do not translate} 
end; 
 
{ TIndySSPINTLMClient } 
 
constructor TIndySSPINTLMClient.Create; 
begin 
  inherited Create; 
  fNTLMPackage := TSSPINTLMPackage.Create; 
  fCredentials := TSSPIWinNTCredentials.Create(fNTLMPackage); 
  fContext := TSSPIClientConnectionContext.Create(fCredentials); 
end; 
 
destructor TIndySSPINTLMClient.Destroy; 
begin 
  fContext.Free; 
  fCredentials.Free; 
  fNTLMPackage.Free; 
  inherited Destroy; 
end; 
 
procedure TIndySSPINTLMClient.SetCredentials 
  (aDomain, aUserName, aPassword: string); 
begin 
  fCredentials.Acquire(scuOutBound, aDomain, aUserName, aPassword); 
end; 
 
procedure TIndySSPINTLMClient.SetCredentialsAsCurrentUser; 
begin 
  fCredentials.Acquire(scuOutBound); 
end; 
 
function TIndySSPINTLMClient.InitAndBuildType1Message: string; 
begin 
  fContext.GenerateInitialChalenge('', Result); 
end; 
 
function TIndySSPINTLMClient.UpdateAndBuildType3Message 
  (aServerType2Message: string): string; 
begin 
  fContext.UpdateAndGenerateReply(aServerType2Message, Result); 
end; 
 
{ TIdSSPINTLMAuthentication } 
 
constructor TIdSSPINTLMAuthentication.Create; 
begin 
  inherited Create; 
  FSSPIClient := TIndySSPINTLMClient.Create; 
end; 
 
function TIdSSPINTLMAuthentication.DoNext: TIdAuthWhatsNext; 
begin 
  result := wnDoRequest; 
  case FCurrentStep of 
    0: 
      begin 
        {if (Length(Username) > 0) and (Length(Password) > 0) then 
        begin} 
        result := wnDoRequest; 
        FCurrentStep := 1; 
        {end 
        else begin 
          result := wnAskTheProgram; 
        end;} 
      end; 
    1: 
      begin 
        FCurrentStep := 2; 
        result := wnDoRequest; 
      end; 
    3: 
      begin 
        FCurrentStep := 4; 
        result := wnDoRequest; 
      end; 
    4: 
      begin 
        FCurrentStep := 0; 
        If Username = '' then 
          result := wnAskTheProgram 
        else 
        result := wnFail; 
      end; 
  end; 
end; 
 
function TIdSSPINTLMAuthentication.Authentication: string; 
var 
  S: string; 
begin 
  result := ''; 
  case FCurrentStep of 
    1: 
      begin 
        if Length(Username) = 0 then 
          FSSPIClient.SetCredentialsAsCurrentUser 
        else 
          FSSPIClient.SetCredentials(IndyGetHostName, Username, Password); 
        result := 'NTLM ' + TIdEncoderMIME.EncodeString(FSSPIClient.InitAndBuildType1Message);  {Do not translate} 
        FNTLMInfo := '';    {Do not translate} 
      end; 
    2: 
      begin 
        if Length(FNTLMInfo) = 0 then 
        begin 
          FNTLMInfo := ReadAuthInfo('NTLM');  {Do not translate} 
          Fetch(FNTLMInfo); 
        end; 
 
        if Length(FNTLMInfo) = 0 then 
        begin 
          Reset; 
          Abort; 
        end; 
 
        S := TIdDecoderMIME.DecodeString(FNTLMInfo); 
        result := 'NTLM ' + TIdEncoderMIME.EncodeString(FSSPIClient.UpdateAndBuildType3Message(S));  {Do not translate} 
        FCurrentStep := 3; 
 
        Inc(FAuthRetries); 
      end; 
    3: begin 
        FCurrentStep := 4; 
      end; 
  end; 
end; 
 
procedure TIdSSPINTLMAuthentication.Reset; 
begin 
  inherited Reset; 
  FCurrentStep := 0; 
end; 
 
function TIdSSPINTLMAuthentication.KeepAlive: Boolean; 
begin 
  result := FCurrentStep >= 1; 
end; 
 
function TIdSSPINTLMAuthentication.GetSteps: Integer; 
begin 
  result := 3; 
end; 
 
initialization 
  g := TSSPIInterface.Create; 
  if g.IsAvailable then 
    RegisterAuthenticationMethod('NTLM', TIdSSPINTLMAuthentication);  {Do not translate} 
finalization 
  g.Free; 
end.