Acquiring a Kerberos ticket with a Delphi application - delphi

Question

I am at a loss here. For some weeks now I tried to get a Kerberos ticket with my Delphi application.
I consulted:
How can I get a Kerberos ticket with Delphi? (I honestly don't see why the bounty was rewarded, btw)
Every page around https://msdn.microsoft.com/en-us/library/aa374713%28v=vs.85%29.aspx
Most importantly: https://msdn.microsoft.com/en-us/library/ee498143.aspx
The last page links to example code that I converted to Delphi - I think. On a form I dropped a TWSocket out of Overbytes Socket components and named it mySocket. Rest is done in code. Problem is, that I seem to get the Kerberos TGT, but can't get the Ticket itself through the UDP connection. The Server just wont answer. I also feel there is something fundamentally wrong here, with the break of media during the communication with the server. How come I can use API to get the TGT but have to switch to UDP to get the ticket itself?
Maybe a good start to discuss this is to ignore the code first and tell me if the way I'm going is right or not. Here are my steps:
Call InitSecurityInterface to get the SecurityFunctionTable
Call QuerySecurityPackageInfo for the Kerberos Package to obtain max message size
Call AcquireCredentialsHandle for Kerberos package
Call InitializeSecurityContext with above received CredentialsHandle and the KerberosServer. Receiving some message, that may contain a KerbTicket a Kerb TGT or anything inbetween
Depending on the result of InitializeSecurityContext either use received KerbTicket or open UDP connection to KerbServer to send received buffer from step 4
Use answer message as parameter for new call of InitilizeSecurityContext
Repeat from Step 4 until result is SEC_E_OK
Have I understood correctly? If so, please consider reading my implementation to find my mistake. If not, please explain how it's really done.
Here is the code:
unit ukerber;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
IdSSPI, IdAuthenticationSSPI, Vcl.StdCtrls, OverbyteIcsWndControl,
OverbyteIcsWSocket;
const
krbServer: PAnsiChar = 'krbtgt/mydomain.int';
type
TForm2 = class(TForm)
Button1: TButton;
Edit1: TEdit;
Button2: TButton;
mySocket: TWSocket;
procedure Button1Click(Sender: TObject);
procedure mySocketDataAvailable(Sender: TObject; ErrCode: Word);
function InitPackage(var maxMessage: Cardinal): Boolean;
function SendUDPMessage(outBuf: Pointer; outsize: Cardinal): Boolean;
function GenClientContext(pIn: Pointer; InputSize: Cardinal; pOut: Pointer; Outputsize: PCardinal; var Done: Boolean): Boolean;
procedure Cleanup;
private
{ Private-Deklarationen }
secfunc: SecurityFunctionTableA;
maxMessageSize: Cardinal;
hCredential: SecHandle;
hContext: CtxtHandle;
pOutBuf, pInBuf: PByteArray;
MessageReceived: Boolean;
public
{ Public-Deklarationen }
end;
procedure Pause(Zeit: Longint);
var
Form2: TForm2;
implementation
{$R *.dfm}
// the main method from the C-example
// this starts the ticket acquisition
procedure TForm2.Button1Click(Sender: TObject);
var
sec_State: SECURITY_STATUS;
pszTargetName: PSEC_CHAR;
hNewContext: CtxtHandle;
Output, Input: SecBufferDesc;
outSecBuf, inSecBuf: SecBuffer;
fContextAttr: ULONG;
cbOut, cbIn: Cardinal;
Done: Boolean;
timeOut: Integer;
begin
Done := False;
if InitPackage(maxMessageSize) then
begin
try
pOutBuf := nil;
pInBuf := nil;
GetMem(pOutBuf, maxMessageSize);
GetMem(pInBuf, maxMessageSize);
SecInvalidateHandle(hCredential);
SecInvalidateHandle(hContext);
if not GenClientContext(nil, 0, pOutBuf, #cbOut, Done) then
begin
Cleanup;
Exit;
end;
// ------------
// up to here everything seem to work just fine
// ------------
if not SendUDPMessage(pOutBuf, cbout) then
begin
Cleanup;
Exit;
end;
timeOut := 0;
while not Done and (timeOut <= 100) do
begin
repeat
Pause(1000);
Inc(timeOut);
until MessageReceived or (timeOut >= 100);
if MessageReceived then
begin
cbOut := maxMessageSize;
if not GenClientContext(pInBuf, cbIn, pOutBuf, #cbout, Done) then
begin
Cleanup;
Exit;
end;
if not SendUDPMessage(pOutBuf, cbout) then
begin
Cleanup;
Exit;
end;
end;
end;
if Done then // <<<----------Sadly... never done
begin
// Kerberos-ticket ---->>>> pInBuf
end
else // this happens every time
ShowMessage('Authentification failed due to server timeout');
finally
Cleanup;
end;
end;
end;
procedure TForm2.Cleanup;
begin
secfunc.DeleteSecurityContext(#hcontext);
secfunc.FreeCredentialsHandle(#hCredential);
FreeMem(pInBuf);
FreeMem(pOutBuf);
end;
function TForm2.GenClientContext(pIn: Pointer; InputSize: Cardinal;
pOut: Pointer; Outputsize: PCardinal; var Done: Boolean): Boolean;
var
sec_State: SECURITY_STATUS;
LifeTime: TimeStamp;
OutBuffDesc: SecBufferDesc;
OutSecBuff: SecBuffer;
InBuffDesc: SecBufferDesc;
InSecBuff: SecBuffer;
ContextAttributes: ULONG;
NewContext: Boolean;
KerberosServer: PAnsiChar;
function SetSecHandle: PSecHandle;
begin
if NewContext then
Result := nil
else
Result := #hContext;
end;
function SetInBuffer: PSecBufferDesc;
begin
if NewContext then
Result := nil
else
Result := #InBuffDesc;
end;
begin
if not Assigned(pIn) then
begin
NewContext := True;
// No user athentication needed, so we'll skip that part of the example
sec_State := secfunc.AcquireCredentialsHandleA(
nil,
PAnsiChar('Kerberos'),
SECPKG_CRED_OUTBOUND,
nil,
nil,
nil,
nil,
#hCredential,
#LifeTime
);
if not SEC_SUCCESS(sec_State) then
begin
ShowMessage('AqcuireCredentials failed, Error#: ' + IntToStr(sec_State));
Result := False;
Exit;
end;
end;
// Prepare buffers
// Output
OutBuffDesc.ulVersion := SECBUFFER_VERSION;
OutBuffDesc.cBuffers := 1;
OutBuffDesc.pBuffers := #OutSecBuff;
OutSecBuff.cbBuffer := Outputsize^;
OutSecBuff.BufferType := SECBUFFER_TOKEN;
OutSecBuff.pvBuffer := pOut;
//Input
InBuffDesc.ulVersion := SECBUFFER_VERSION;
InBuffDesc.cBuffers := 1;
InBuffDesc.pBuffers := #InSecBuff;
InSecBuff.cbBuffer := InputSize;
InSecBuff.BufferType := SECBUFFER_TOKEN;
InSecBuff.pvBuffer := pIn;
// KerberosServer := krbServer; // Tried both krbtgt and following...no change
KerberosServer := PAnsiChar('RestrictedKrbHost/FM-DC01.mydomain.int');
sec_State := secfunc.InitializeSecurityContextA(
#hCredential,
SetSecHandle,
KerberosServer,
ISC_REQ_DELEGATE + ISC_REQ_MUTUAL_AUTH,
0,
SECURITY_NATIVE_DREP,
SetInBuffer,
0,
#hContext,
#OutBuffDesc,
#contextAttributes,
#Lifetime
);
if not SEC_SUCCESS(sec_State) then
begin
ShowMessage('init context failed, Error #: ' + IntToStr(sec_State));
Result := False;
Exit;
end;
if (sec_State = SEC_I_COMPLETE_NEEDED) or
(sec_State = SEC_I_COMPLETE_AND_CONTINUE) then
begin
sec_State := secfunc.CompleteAuthToken(#hContext, #OutBuffDesc);
if not SEC_SUCCESS(sec_State) then
begin
ShowMessage('complete failed, Error #: ' + IntToStr(sec_State));
Result := False;
Exit;
end;
end;
Outputsize^ := OutSecBuff.cbBuffer;
// First call of this method results in sec_state = SEC_I_CONTINUE_NEEDED
// which should be OK, but then I have to switch to UDP communication
// and that seems to be buggy.
Done := not ((sec_State = SEC_I_CONTINUE_NEEDED) or (sec_State = SEC_I_COMPLETE_AND_CONTINUE));
Result := True;
end;
function TForm2.InitPackage(var maxMessage: Cardinal): Boolean;
var
sec_State: SECURITY_STATUS;
pPkgInfo: PSecPkgInfoA;
InitSecurityInterfaceA: function: PSecurityFunctionTableA; stdcall;
begin
Result := False;
MessageReceived := False;
try
InitSecurityInterfaceA := GetProcAddress(GetModuleHandle('secur32.dll'), 'InitSecurityInterfaceA');
if Assigned(InitSecurityInterfaceA) then
secfunc := InitSecurityInterfaceA^;
sec_State := secfunc.QuerySecurityPackageInfoA(
PAnsiChar('Kerberos'),
#pPkgInfo
);
if sec_state = SEC_E_OK then
begin
maxMessage := pPkgInfo^.cbMaxToken;
Result := True;
end;
finally
secfunc.FreeContextBuffer(pPkgInfo);
end;
end;
procedure TForm2.mySocketDataAvailable(Sender: TObject; ErrCode: Word);
var
inBuf: array of Byte;
BufLen: Integer;
Length: Integer;
sentSize: Cardinal;
begin
MessageReceived := False;
// Data should pour in here. Hopefully the Kerberos-ticket
// First DWORD is message size, rest is the message itself
Length := mySocket.Receive(#sentsize, SizeOf(DWORD));
if Length <= 0 then
begin
Exit;
end;
// The rest
SetLength(inBuf, SizeOf(sentSize));
Length := mySocket.Receive(#inBuf, SizeOf(inBuf));
if Length >= 0 then
begin
pInBuf := #inBuf;
MessageReceived := True;
end;
end;
function TForm2.SendUDPMessage(outBuf: Pointer; outsize: Cardinal): Boolean;
begin
mySocket.Proto := 'udp';
mySocket.Addr := 'FM-DC01.mydomain.int';
mySocket.Port := '88';
mySocket.Connect;
// send size of message first, then message itself
Result := (mySocket.Send(PByte(#outsize), SizeOf(outsize)) > -1);
if Result then
if mySocket.State = wsConnected then
Result := (mySocket.Send(outBuf, outsize) > -1);
end;
// small method to wait for action, should not be part of the problem
procedure Pause(Zeit: Longint);
var
Tick: DWORD;
Event: THandle;
begin
Event := CreateEvent(nil, False, False, nil);
try
Tick := GetTickCount + DWORD(Zeit);
while (Zeit > 0) and
(MsgWaitForMultipleObjects(1, Event, False, Zeit, QS_ALLINPUT) <> WAIT_TIMEOUT) do
begin
Application.ProcessMessages;
Zeit := Tick - GetTickCount;
end;
finally
CloseHandle(Event);
end;
end;
end.