unit MainUnit;
interface
uses
Winapi.Windows,
Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
Vcl.Graphics,
Vcl.Controls,
Vcl.Forms,
Vcl.Dialogs,
Vcl.StdCtrls,
JwaSspi, JwaWinDNS, IdBaseComponent, IdComponent, IdTCPConnection, IdDNSResolver;
type
TForm1 =
class(TForm)
Memo1: TMemo;
Button1AcquireCredentialsHandle: TButton;
procedure Button1AcquireCredentialsHandleClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
protected
function GetAuth(): TBytes;
function getKerberosSPN(userName:
String):WideString;
private
{ Private-Deklarationen }
// sind derzeit keine properties...
FMaxMessageLen: Cardinal;
FCred: SecHandle;
FCredCtx :CtxtHandle;
FContextAttrib: Cardinal;
FSPN: WideString;
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses
WinSock;
const
SEC_E_OK = 0;
{$EXTERNALSYM SEC_E_OK}
SEC_I_CONTINUE_NEEDED = HRESULT($00090312);
{$EXTERNALSYM SEC_I_CONTINUE_NEEDED}
SEC_I_COMPLETE_NEEDED = HRESULT($00090313);
{$EXTERNALSYM SEC_I_COMPLETE_NEEDED}
SEC_I_COMPLETE_AND_CONTINUE = HRESULT($00090314);
{$EXTERNALSYM SEC_I_COMPLETE_AND_CONTINUE}
// https://docs.microsoft.com/en-us/windows/win32/secauthn/sspi-kerberos-interoperability-with-gssapi
function TForm1.GetAuth(): TBytes;
var
pkgInfo: PSecPkgInfo;
SecBuf: SecBuffer;
BuffDesc: SecBufferDesc;
status: SECURITY_STATUS;
attrs: Cardinal;
tsExpiry: TTimeStamp;
attrName: SecPkgCredentials_Names;
const
NEG_STR: WideString = '
Kerberos';
// 'NTLM'; // 'Negotiate';
begin
// https://stackoverflow.com/questions/33829755/sspi-and-sql-server-windows-authentication
// https://entwickler-ecke.de/topic_Existiert+BenutzerPasswort+am+System+geloest_13781,0.html
// https://github.com/graemeg/freepascal/blob/master/packages/winunits-jedi/src/jwasspi.pas
Result :=
nil;
status := QuerySecurityPackageInfo(PSecWChar(NEG_STR), pkgInfo);
if status <> SEC_E_OK
then
raise Exception.CreateFmt('
Couldn''
t query package info for %s, error %X', [NEG_STR, status]);
FMaxMessageLen := pkgInfo.cbMaxToken;
// 4096;
FreeContextBuffer(pkgInfo);
TTimeStamp(tsExpiry).QuadPart := 0;
status := AcquireCredentialsHandle(
nil, PSecWChar(NEG_STR), SECPKG_CRED_OUTBOUND,
// SECPKG_CRED_BOTH
nil,
nil,
nil,
nil, @FCred, tsExpiry);
// tsExpiry as var parameter
if status <> SEC_E_OK
then
raise Exception.CreateFmt('
AcquireCredentialsHandle error %X', [status]);
BuffDesc.ulVersion := SECBUFFER_VERSION;
BuffDesc.cBuffers := 1;
BuffDesc.pBuffers := @SecBuf;
SecBuf.BufferType := SECBUFFER_TOKEN;
SetLength(Result, FMaxMessageLen);
SecBuf.pvBuffer := @Result[0];
SecBuf.cbBuffer := FMaxMessageLen;
status := QueryCredentialsAttributes(@FCred, SECPKG_CRED_ATTR_NAMES, @attrName);
if status <> SEC_E_OK
then
raise Exception.CreateFmt('
QueryCredentialsAttributes error %X', [status]);
Memo1.Lines.Add('
result of QueryCredentialsAttributes: '+PWideChar(attrName.sUserName));
// Now build the correct format.
FSPN := getKerberosSPN(PWideChar(attrName.sUserName));
Memo1.Lines.Add('
SPN used: '+FSPN);
// something like RestrictedKrbHost/fqdn-of-kerberos-server;
FContextAttrib := ISC_REQ_DELEGATE
or ISC_REQ_MUTUAL_AUTH
or ISC_REQ_INTEGRITY
or ISC_REQ_EXTENDED_ERROR;
// ISC_REQ_CONFIDENTIALITY or ISC_REQ_REPLAY_DETECT or ISC_REQ_CONNECTION;
// $8C03C;
// ISC_REQ_MUTUAL_AUTH or ISC_REQ_IDENTIFY or ISC_REQ_CONFIDENTIALITY or ISC_REQ_REPLAY_DETECT or ISC_REQ_SEQUENCE_DETECT or ISC_REQ_CONNECTION or ISC_REQ_DELEGATE;
status := InitializeSecurityContext(@FCred,
nil, PSecWChar(FSPN),
FContextAttrib,
0, SECURITY_NATIVE_DREP,
nil, 0, @FCredCtx, @BuffDesc, attrs, @tsExpiry);
if status <= 0
then
raise Exception.CreateFmt('
InitializeSecurityContext error %X', [status]);
if (status = SEC_I_COMPLETE_NEEDED)
or (status = SEC_I_COMPLETE_AND_CONTINUE)
or (status = SEC_I_CONTINUE_NEEDED)
then begin
status := CompleteAuthToken(@FCredCtx, @BuffDesc);
if status <> SEC_E_OK
then begin
FreeCredentialsHandle(@FCred);
Result :=
nil;
raise Exception.CreateFmt('
CompleteAuthToken error %X', [status]);
end;
end
else if (status <> SEC_E_OK)
and (status <> SEC_I_CONTINUE_NEEDED)
then begin
// SEC_I_CONTINUE_NEEDED
// The client must send the output token to the server and wait for a return token.
// The returned token is then passed in another call to InitializeSecurityContext (Negotiate). The output token can be empty
FreeCredentialsHandle(@FCred);
Result :=
nil;
raise Exception.CreateFmt('
InitializeSecurityContext error %X', [status]);
end;
SetLength(Result, SecBuf.cbBuffer);
if status = SEC_E_OK
then
Memo1.Lines.Add('
result is SEC_E_OK');
end;
function TForm1.getKerberosSPN(userName:
String):WideString;
// @ToDo: String / Widestring bereinigen
var
strArray: TArray<
String>;
queryDomain:
string;
kerberosHostname:
string;
DNS_REC: PDNS_RECORD;
begin
// https://searchfox.org/mozilla-central/source/extensions/auth/nsAuthSSPI.cpp
// -> MakeSN()
// https://searchfox.org/mozilla-central/source/netwerk/dns/nsDNSService2.cpp
// https://www.msxfaq.de/windows/kerberos/kerberosspn.htm
// https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-adts/7fcdce70-5205-44d6-9c3a-260e616a2f04
result:='
';
// userName should be something like
// username@fqdn
strArray := userName.Split(['
@']);
if length(strArray) <> 2
then
raise Exception.CreateFmt('
invalid Username', []);
// SRV Record für kerberos Server abfragen
queryDomain := '
_kerberos._tcp.'+strArray[1];
// Memo1.Lines.Add('Abfrage Kerberos-Server: '+queryDomain);
// https://www.codenewsfast.com/cnf/article/0/permalink.art-ng1921q9862
// über Win32 API
// über Indy müsste man erst System-DNS bestimmen - das lassen wir mal Windows machen :-)
// https://stackoverflow.com/questions/6444102/look-up-if-mail-server-exists-for-list-of-emails
kerberosHostname:='
';
if DnsQuery(PWideChar(queryDomain), DNS_TYPE_SRV, 0,
nil, @DNS_REC,
nil) = 0
then begin
while assigned(DNS_REC)
do begin
if DNS_REC.wType = DNS_TYPE_SRV
then begin
// do something...
kerberosHostname:=DNS_REC.Data.SRV.pNameTarget;
end;
DNS_REC := DNS_REC.pNext;
end;
end;
if kerberosHostname = '
'
then
raise Exception.CreateFmt('
could not determinate kerberos server!', []);
// Memo1.Lines.Add(' -> '+kerberosHostname);
result := Format('
%s/%s', ['
RestrictedKrbHost', kerberosHostname]);
end;
procedure TForm1.Button1AcquireCredentialsHandleClick(Sender: TObject);
begin
Memo1.Lines.Clear;
GetAuth();
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Button1AcquireCredentialsHandleClick(
nil);;
end;
end.