Trying to get Webauthn running - delphi

I've started a Fido2/WebAuthn project a while ago and tried to get microsofts webauthn implementation starting. For this in this project there exists a
translation of the webauthn.h file
(as today I only found refernces to this file in Mozilla and Chromium browsers code...).
Now ... I simply tried to create form with a button issuing a command to create credentials but
this call fails miserably with an access violation # $0000EA60 and I have no clue what that might cause. What might I do wrong???
Here the code for a button onClick handler.
uses Webauthn;
// just a test JSON object that I obtained from a browser request
const cClientData : UTF8String = '{' +
'"hashAlgorithm": "SHA-256",' +
'"challenge": "fzjg31IEKi6ZxKqsQ9S_XHG9WvdmcXPah5EXd11p1bU",' +
'"origin": "https:\/\/fidotest.com",' +
'"clientExtensions": {},' +
'"type": "webauthn.create"' +
'}';
procedure TfrmWebAuthnTest.btnCredentialClick(Sender: TObject);
var RpInformation : TWebAuthnRPEntityInformation; // _In_
UserInformation : TWebAuthUserEntityInformation; // _In_
PubKeyCredParams : TWebauthnCoseCredentialParameters; // _In_
WebAuthNClientData : TWebAuthnClientData; // _In_
WebAuthNMakeCredentialOptions : TWebAuthnAuthenticatorMakeCredentialOptions; // _In_opt_
pWebAuthNCredentialAttestation : PWEBAUTHN_CREDENTIAL_ATTESTATION; // _Outptr_result_maybenull_
hr : HRESULT;
coseParams : Array[0..1] of WEBAUTHN_COSE_CREDENTIAL_PARAMETER;
i : integer;
challenge : Array[0..31] of byte;
cancellationID : TGuid;
bufClientData : UTF8String;
begin
// ################################################
// #### relying party
FillChar(RpInformation, sizeof(RpInformation), 0);
RpInformation.dwVersion := WEBAUTHN_RP_ENTITY_INFORMATION_CURRENT_VERSION;
RpInformation.pwszId := 'fidotest.com';
RpInformation.pwszName := 'Sweet home localhost';
RpInformation.pwszIcon := nil;
// ################################################
// #### user information
FillChar(UserInformation, sizeof(UserInformation), 0);
UserInformation.dwVersion := WEBAUTHN_USER_ENTITY_INFORMATION_CURRENT_VERSION;
UserInformation.cbId := sizeof( challenge );
Randomize;
// create credentials
for i := 0 to Length(challenge) - 1 do
begin
challenge[i] := Byte( Random(High(byte) + 1) );
end;
UserInformation.pbId := #challenge[0];
UserInformation.pwszName := 'Mike';
UserInformation.pwszIcon := niL;
UserInformation.pwszDisplayName := 'Mike Rabat';
// ################################################
// #### Client data
bufClientData := Copy( cClientData, 1, Length(cClientData));
FillChar(WebAuthNClientData, sizeof(WebAuthNClientData), 0);
WebAuthNClientData.dwVersion := WEBAUTHN_CLIENT_DATA_CURRENT_VERSION;
WebAuthNClientData.cbClientDataJSON := Length(cClientData);
WebAuthNClientData.pbClientDataJSON := PAnsiChar(bufClientData);
WebAuthNClientData.pwszHashAlgId := WEBAUTHN_HASH_ALGORITHM_SHA_256;
// ################################################
// #### pub ked credential params
PubKeyCredParams.cCredentialParameters := sizeof(coseParams);
PubKeyCredParams.pCredentialParameters := #coseParams[0];
coseParams[0].dwVersion := WEBAUTHN_COSE_CREDENTIAL_PARAMETER_CURRENT_VERSION;
coseParams[0].pwszCredentialType := WEBAUTHN_CREDENTIAL_TYPE_PUBLIC_KEY;
coseParams[0].lAlg := WEBAUTHN_COSE_ALGORITHM_ECDSA_P256_WITH_SHA256;
coseParams[1].dwVersion := WEBAUTHN_COSE_CREDENTIAL_PARAMETER_CURRENT_VERSION;
coseParams[1].pwszCredentialType := WEBAUTHN_CREDENTIAL_TYPE_PUBLIC_KEY;
coseParams[1].lAlg := WEBAUTHN_COSE_ALGORITHM_RSASSA_PKCS1_V1_5_WITH_SHA256;
// ###########################################
// #### Fill in params
FillChar(WebAuthNMakeCredentialOptions, sizeof(WebAuthNMakeCredentialOptions), 0);
WebAuthNMakeCredentialOptions.dwVersion := WEBAUTHN_AUTHENTICATOR_MAKE_CREDENTIAL_OPTIONS_CURRENT_VERSION;
WebAuthNMakeCredentialOptions.dwTimeoutMilliseconds := 60000;
WebAuthNMakeCredentialOptions.bRequireResidentKey := False;
WebAuthNMakeCredentialOptions.dwAuthenticatorAttachment := WEBAUTHN_AUTHENTICATOR_ATTACHMENT_CROSS_PLATFORM;
WebAuthNMakeCredentialOptions.dwUserVerificationRequirement := WEBAUTHN_USER_VERIFICATION_REQUIREMENT_REQUIRED;
WebAuthNMakeCredentialOptions.dwAttestationConveyancePreference := WEBAUTHN_ATTESTATION_CONVEYANCE_PREFERENCE_DIRECT;
// ###########################################
// #### Cancellation
assert( WebAuthNGetCancellationId(cancellationID) = S_OK, 'Cancellation ID failed');
WebAuthNMakeCredentialOptions.pCancellationId := #cancellationID;
// ###########################################
// #### do the magic
pWebAuthNCredentialAttestation := nil;
hr := WebAuthNAuthenticatorMakeCredential( Handle,
#RpInformation,
#UserInformation,
#PubKeyCredParams,
#WebAuthNClientData,
#WebAuthNMakeCredentialOptions,
pWebAuthNCredentialAttestation );
if hr = S_OK then
begin
// WriteCredAttest( pWebAuthNCredentialAttestation );
WebAuthNFreeCredentialAttestation( pWebAuthNCredentialAttestation );
memLog.Lines.Add('Finished');
end
else
begin
memLog.Lines.Add('Make Cred failed with: ' + WebAuthNGetErrorName( hr ));
end;
end;
I'm using Delphi2010 so all strings should be unicode except the JSON client data string.

After lengthy study of the C++ code of the Mozilla Browser I think I found the problem.
It was in the size field of the COSE_PARAMS structure.
// #### pub ked credential params
PubKeyCredParams.cCredentialParameters := Length(coseParams);// sizeof(coseParams);
PubKeyCredParams.pCredentialParameters := #coseParams[0];
Instead of the size in bytes they seem to expect the length of the array of the
attached coseParams. That misunderstanding led to the AV.

Related

Webauthn credential verifiation with fido2.dll fro Yubico

I started to interface yubicos fido2.dll in Delphi and was able to interface it
according to the provided examples. Now I want to go a step further and use the
dll on an e.g. apache server to handle credential creation and assertion.
So.. for this I basically use the javascripts found on THE testing site https://webauthn.io/
Basically I wanted to mimic some server functions for credential creation. On the website one can setup
some properties - in my environment they come from the server.
Currently I have made the communication from Client to issue a credential initialization - server responses with a challange. The Key is queried and the browser creates credentials and sends it back to the server. This though where I have a problem with the data coming from the server aka I have a
problem decoding the attestationObject part.
So here is the credential init json from my server:
{"publicKey":{"challenge":"LFJYIdXJfYpB1GZS+PzEOD8DNcYmdia4mZp2z0J4QcE=","pubKeyCredParams":[{"alg":-7,"type":"public-key"},{"alg":-257,"type":"public-key"},{"alg":-8,"type":"public-key"}],"authenticatorSelection":{"authenticatorAttachment":"cross-platform","userVerification":"required","requireResidentKey":false},"rp":{"id":"fidotest.com","name":"fidotest.com"},"user":{"id":"zVOUjBCxJNIbSSWNiGOv2\/kZP2UU8pPguVylFeiw4HE=","displayName":"test","name":"test"},"Timeout":60000,"attestation":"direct"}}
And the result from the server:
{"id":"MfcgyBxDxpq5S71fB45FFjecCGtvCepvb6IZexJpgaHyTPPsaz0srQyZc26HkE92eda7a2PmPIzvSpLbipktmw","rawId":"MfcgyBxDxpq5S71fB45FFjecCGtvCepvb6IZexJpgaHyTPPsaz0srQyZc26HkE92eda7a2PmPIzvSpLbipktmw","type":"public-key","response":{"attestationObject":"o2NmbXRmcGFja2VkZ2F0dFN0bXSjY2FsZyZjc2lnWEcwRQIhAO8fbE8iQcMFYE4KBwL6HK6OxSReRKriXZDWhcfGRMFxAiB7mIPZ7n-fWas7aWkEkWd-9CWvd8ncRVCh3BBFIzMuRmN4NWOBWQLAMIICvDCCAaSgAwIBAgIEBMX-_DANBgkqhkiG9w0BAQsFADAuMSwwKgYDVQQDEyNZdWJpY28gVTJGIFJvb3QgQ0EgU2VyaWFsIDQ1NzIwMDYzMTAgFw0xNDA4MDEwMDAwMDBaGA8yMDUwMDkwNDAwMDAwMFowbTELMAkGA1UEBhMCU0UxEjAQBgNVBAoMCVl1YmljbyBBQjEiMCAGA1UECwwZQXV0aGVudGljYXRvciBBdHRlc3RhdGlvbjEmMCQGA1UEAwwdWXViaWNvIFUyRiBFRSBTZXJpYWwgODAwODQ3MzIwWTATBgcqhkjOPQIBBggqhkjOPQMBBwNCAAQc2Np2EaP17x-IXpULpl2A4zSFU5FYS9R_W3GcUyNcJCHk45m9tXNngkGQk1dmYUk8kUwuZyTfk5T8-n3qixgEo2wwajAiBgkrBgEEAYLECgIEFTEuMy42LjEuNC4xLjQxNDgyLjEuMTATBgsrBgEEAYLlHAIBAQQEAwIFIDAhBgsrBgEEAYLlHAEBBAQSBBD4oBHzjApNFYAGFxEfntx9MAwGA1UdEwEB_wQCMAAwDQYJKoZIhvcNAQELBQADggEBAHcYTO91LRoF8wpThdwthvj6wGNxcLAiYqUZXPX-0Db-AGVODSkVvEVSmj-JXmrBzNQel3FW4AupOgbgrJmmcWWEBZyXSpRQtYcl2LTNU0-Iz9WbyHNN1wQJ9ybFwj608xBuoNRC0rG8wgYbMC4usyRadt3dYOVdQi0cfaksVB2VNKnw-ttQUWKoZsPHtuzFx8NlazLQBep1W2T0FCONFEG7x_l-ZcfNhT13azAbaurJ2J0_ff6H0PXJP6h-Obne4xfz0-8ujftWDUSh9oaiVRYf-tgam_tzOKyEU38V2liV11zMyHKWrXiK0AfyDgb58ky2HSrn_AgE5MW_oXg_CXdoYXV0aERhdGFYxNNxx2kdwL5GE4VmZm0_PerRaSEQdriBtCqmPBobyJXTRQAAAA34oBHzjApNFYAGFxEfntx9AEAx9yDIHEPGmrlLvV8HjkUWN5wIa28J6m9vohl7EmmBofJM8-xrPSytDJlzboeQT3Z51rtrY-Y8jO9KktuKmS2bpQECAyYgASFYIPVUDt7LCfuPyhdowBAhHCaRp-4acTmevkowvQhYxQluIlggCOL0rfuXgGze8yGX38sBXzsSMqxQxiskjsXia6UQvtQ","clientDataJSON":"eyJjaGFsbGVuZ2UiOiJMRkpZSWRYSmZZcEIxR1pTLVB6RU9EOEROY1ltZGlhNG1acDJ6MEo0UWNFIiwiY2xpZW50RXh0ZW5zaW9ucyI6e30sImhhc2hBbGdvcml0aG0iOiJTSEEtMjU2Iiwib3JpZ2luIjoiaHR0cHM6Ly9maWRvdGVzdC5jb20iLCJ0eXBlIjoid2ViYXV0aG4uY3JlYXRlIn0"}}
Here is a console program that should verify the credentials:
(note you need to paste the above content to a textfile and load it in the console).
program VerifyCred;
{$APPTYPE CONSOLE}
uses
SysUtils,
Fido2 in '..\Fido2.pas',
Fido2dll in '..\Fido2dll.pas',
Fido2Json in '..\Fido2Json.pas',
windows,
classes,
cbor,
superobject;
function DoVerifyCred( credential : ISuperObject ) : string;
var clientData : ISuperObject;
s : string;
rawS : RawByteString;
credentialId : string;
rawId : TBytes;
credVerify : TFidoCredVerify;
cborItem : TCborMap;
sig : TBytes;
x5c : TBytes;
authData : TBytes;
fmt : string;
alg : integer;
i : integer;
aName : string;
res : boolean;
rawChallange : RawByteString;
credFMT : TFidoCredentialFmt;
challenge : TFidoChallenge;
authDataObj : TAuthData;
attStmt : TCborMap;
j : integer;
restBuf : TBytes;
begin
Result := '{"error":0,"msg":"Error parsing content"}';
s := credential.S['response.clientDataJSON'];
if s = '' then
exit;
ClientData := So( String(Base64URLDecode( s )) );
if clientData = nil then
exit;
rawChallange := Base64URLDecode(ClientData.S['challenge']);
if Length(rawChallange) <> sizeof(challenge) then
exit;
Move( rawChallange[1], challenge, sizeof(challenge));
clientData := SO( String( Base64URLDecode( credential.S['response.clientDataJSON'] ) ) );
s := credential.S['response.attestationObject'];
if s = '' then
exit;
// attestation object is a cbor encoded raw base64ulr encoded string
cborItem := TCborDecoding.DecodeBase64UrlEx(s, restBuf) as TCborMap;
if not Assigned(cborItem) then
exit;
try
alg := 0;
fmt := '';
sig := nil;
authData := nil;
x5c := nil;
for i := 0 to cborItem.Count - 1 do
begin
assert( cborItem.Names[i] is TCborUtf8String, 'CBOR type error');
aName := String((cborItem.Names[i] as TCborUtf8String).Value);
if SameText(aName, 'attStmt') then
begin
attStmt := cborItem.Values[i] as TCborMap;
for j := 0 to attStmt.Count - 1 do
begin
aName := String((attStmt.Names[j] as TCborUtf8String).Value);
if SameText(aName, 'alg')
then
alg := (attStmt.Values[j] as TCborNegIntItem).value
else if SameText(aName, 'sig')
then
sig := (attStmt.Values[j] as TCborByteString).ToBytes
else if SameText(aName, 'x5c')
then
x5c := ((attStmt.Values[j] as TCborArr)[0] as TCborByteString).ToBytes
end;
end
else if SameText(aName, 'authData')
then
authData := (cborItem.Values[i] as TCborByteString).ToBytes
else if SameText(aName, 'fmt')
then
fmt := String( (cborItem.Values[i] as TCborUtf8String).Value );
end;
finally
cborItem.Free;
end;
// check if anyhing is in place
if not (( alg = COSE_ES256 ) or (alg = COSE_EDDSA) or (alg= COSE_RS256)) then
raise Exception.Create('Unknown algorithm');
if Length(sig) = 0 then
raise Exception.Create('No sig field provided');
if Length(x5c) = 0 then
raise Exception.Create('No certificate');
if Length(authData) = 0 then
raise Exception.Create('Missing authdata');
credentialId := credential.S['id'];
s := credential.S['rawId'];
if s = '' then
raise Exception.Create('No Credential id found');
raws := Base64URLDecode( s );
SetLength( rawId, Length(rawS));
Move( rawS[1], rawId[0], Length(rawId));
authDataObj := nil;
if Length(restBuf) > 0 then
raise Exception.Create('Damend there is a rest buffer that should not be');
if Length(authDAta) > 0 then
authDataObj := TAuthData.Create( authData );
try
if fmt = 'packed'
then
credFmt := fmFido2
else if fmt = 'fido-u2f'
then
credFmt := fmU2F
else
credFmt := fmDef;
// now... verify the credentials
credVerify := TFidoCredVerify.Create( TFidoCredentialType(alg), credFmt,
authData, x5c, sig, FidoServer.RequireResidentKey,
authDataObj.UserVerified, 0) ;
try
// auth data seems bad!
res := credVerify.Verify(challenge);
if res then
begin
// -> save EVERYTHING to a database
end;
finally
credVerify.Free;
end;
finally
authDataObj.Free;
end;
// build result and generate a session
if res then
begin
// yeeeha we got a
Result := '{"success":true}';
end
else
Result := '{"success":false}';
end;
var credential: ISuperObject;
begin
try
with TStringList.Create do
try
LoadFromFile('D:\CredVerify_delphi.json');
credential := SO( Text );
finally
Free;
end;
Writeln( doVerifyCred(credential) );
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
The cbor and fido2 projects can be found on github.
I actually have a problem with the CBOR encoded attestationObject returned. If the resident key property is set the
attestation object is only 63 bytes long - and there are bytes left that are actually not encoded. So...
The cbor decoding there either fails or I get data back that does not conform the webauthn attestation object which should at
these positions return the credential id and the public key (which is then also cbor encoded). If the resident key property is false
as this is the case in the above statement the fido dll returns bad auth data. So... anyone has a clue what I'm doing wrong?
It should basically look like in the diagram but it ends either after 63 bytes which is in the mids of the credential id or it fails in the dll.
Turned out I misused the indy base64 routines. The base64 decoder did not work properly for a Unicodstring (I assumed that the string was converted to an ansistring...)
So instead I use the following decoder:
function Base64Decode( s : string ) : RawByteString;
var aWrapStream : TWrapMemoryStream;
sconvStr : UTF8String;
lStream : TMemoryStream;
begin
sConvStr := UTF8String( s );
aWrapStream := TWrapMemoryStream.Create( #sConvStr[1], Length(sConvStr) );
lStream := TMemoryStream.Create;
try
with TIdDecoderMIME.Create(nil) do
try
DecodeBegin(lStream);
Decode( aWrapStream );
DecodeEnd;
SetLength(Result, lStream.Size );
if lStream.Size > 0 then
Move( PByte(lStream.Memory)^, Result[1], lStream.Size);
finally
Free;
end;
finally
lStream.Free;
end;
aWrapStream.Free;
end;

DirectX/DirectCompute CreateBuffer failure with error 0x80070057 (E_INVALIDARG)

I'm trying to create a buffer in GPU memory to upload data from CPU. GPU access will be readonly. Data will be used as an input buffer for a compute shader.
CreateBuffer() fails with error 0x80070057 (E_INVALIDARG). I read the docs and read it again without discovering which argument cause the failure.
InitDevice() return success.
Here is an extract from my code:
function TGpuImageControl.InitDevice: HRESULT;
var
hr : HRESULT;
createDeviceFlags : UINT;
driverTypes : array [0..0] of D3D_DRIVER_TYPE;
numDriverTypes : UINT;
driverTypeIndex : UINT;
sd : DXGI_SWAP_CHAIN_DESC;
FeatureLevels : D3D_FEATURE_LEVEL;
featureLevel : D3D_FEATURE_LEVEL;
const
D3D10_SHADER_DEBUG = 1;
begin
hr := S_OK;
createDeviceFlags := 0;
{$ifdef DEBUG}
createDeviceFlags := createDeviceFlags or D3D11_CREATE_DEVICE_DEBUG;
{$endif}
{$ifdef WARP}
driverTypes[0] := D3D_DRIVER_TYPE_REFERENCE;
{$else}
driverTypes[0] := D3D_DRIVER_TYPE_HARDWARE;
{$endif}
numDriverTypes := SizeOf(driverTypes) div SizeOf(driverTypes[0]);
ZeroMemory(#sd, SizeOf(sd));
sd.BufferCount := 1;
sd.BufferDesc.Width := width;
sd.BufferDesc.Height := height;
sd.BufferDesc.Format := DXGI_FORMAT_R8G8B8A8_UNORM;
sd.BufferDesc.RefreshRate.Numerator := 60;
sd.BufferDesc.RefreshRate.Denominator := 1;
sd.BufferUsage := DXGI_USAGE_RENDER_TARGET_OUTPUT or
DXGI_USAGE_UNORDERED_ACCESS;// or
//DXGI_USAGE_SHADER_INPUT;
sd.OutputWindow := Handle;
sd.SampleDesc.Count := 1;
sd.SampleDesc.Quality := 0;
sd.Windowed := TRUE;
//sd.Flags := DXGI_SWAP_CHAIN_FLAG_ALLOW_MODE_SWITCH;
FeatureLevels := D3D_FEATURE_LEVEL_11_0;
for driverTypeIndex := 0 to numDriverTypes do begin
g_driverType := driverTypes[driverTypeIndex];
hr := D3D11CreateDeviceAndSwapChain(
nil, // Graphic Adapter, use default
g_driverType, // Driver type to use
0, // HModule for software driver
createDeviceFlags, // Create flags
#FeatureLevels, // Feature levels
1, // Feature level size
D3D11_SDK_VERSION, // SDK Version
#sd, // Swap Chain descriptor
g_pSwapChain, // Out: Created swap chain
g_pd3dDevice, // Out: Created device
featureLevel, // Out: Feature level
g_pImmediateContext); // Out: Context
if SUCCEEDED(hr) then
break;
end;
if FAILED(hr) then begin
Result := hr;
Exit;
end;
ImageResize();
Result := S_OK;
end;
procedure TGpuImageControl.ImageResize;
var
hr : HRESULT;
sd : DXGI_SWAP_CHAIN_DESC;
pTexture : ID3D11Texture2D;
vp : D3D11_VIEWPORT;
begin
if g_pd3dDevice = nil then
Exit;
// release first else resize problem
SAFE_RELEASE(IUnknown(g_pComputeOutput));
g_pSwapChain.GetDesc(sd);
hr := g_pSwapChain.ResizeBuffers(sd.BufferCount,
Width,
Height,
sd.BufferDesc.Format,
0); // Swap chain flags
if FAILED(hr) then begin
ShowError('SwapChain.ResizeBuffers failed with error %d', [hr]);
Exit;
end;
hr := g_pSwapChain.GetBuffer(0, TGUID(ID3D11Texture2D), pTexture);
if FAILED(hr) then begin
ShowError('SwapChain.GetBuffer failed with error %d', [hr]);
Exit;
end;
// create shader unordered access view on back buffer for compute shader to write into texture
hr := g_pd3dDevice.CreateUnorderedAccessView(pTexture,
nil,
g_pComputeOutput);
if FAILED(hr) then begin
ShowError('pd3dDevice.CreateUnorderedAccessView failed with error %d', [hr]);
Exit;
end;
pTexture := nil;
// Setup the viewport
vp.Width := Width;
vp.Height := Height;
vp.MinDepth := 0.0;
vp.MaxDepth := 1.0;
vp.TopLeftX := 0;
vp.TopLeftY := 0;
g_pImmediateContext.RSSetViewports(1, #vp);
end;
The code which fails is the following:
function TGpuImageControl.CreateStructuredBuffer(
uElementSize : UINT;
uCount : UINT;
pInitData : Pointer;
out ppBufOut : ID3D11Buffer): HRESULT;
var
desc : D3D11_BUFFER_DESC;
InitData : D3D11_SUBRESOURCE_DATA;
begin
ppBufOut := nil;
ZeroMemory(#desc, SizeOf(desc));
desc.BindFlags := D3D11_BIND_UNORDERED_ACCESS or
D3D11_BIND_SHADER_RESOURCE;
desc.Usage := D3D11_USAGE_DYNAMIC;
desc.CPUAccessFlags := D3D11_CPU_ACCESS_WRITE;
desc.ByteWidth := uElementSize * uCount;
desc.MiscFlags := UINT(D3D11_RESOURCE_MISC_BUFFER_STRUCTURED);
desc.StructureByteStride := uElementSize;
if pInitData <> nil then begin
InitData.pSysMem := pInitData;
Result := g_pd3dDevice.CreateBuffer(desc, #InitData, ppBufOut);
end
else
Result := g_pd3dDevice.CreateBuffer(desc, nil, ppBufOut);
end;
When calling the function, I pass uElementSize=2, uCount=100 and pInitData pointing to an allocated 200 bytes buffer in CPU memory.
I don't understand what I'm doing wrong.
Any help appreciated.
The answer has been given by Chuck Walbourn to the C++ question I asked there DirectCompute CreateBuffer fails with error 0x80070057 (E_INVALIDARG)
The most important part to debug this error is simply look at Delphi Event Viewer and just look the error message the API is triggering when debugging is enabled (I I already had enabled debugging but didn't figured that messages where output to the events windows).

User Friendly Name from system account, workgroup

My process (regular app, not a service. app is launched by service, not by user, but in user's session) runs under SYSTEM account (it's required by other reasons) in user's session(s). Is there any way to get current session's user friendly name if the PC is in a workgroup?
-getting desktop's ('Progrman') user as -GetTokenInformation - LookupAccountSid - and making a TranslateName does not give me the f.name () in a workgroup (as written in msdn, it works in a domain).
-GetUserNameExW does not give me f.name because my process works under SYSTEM account (GetUserNameExW retrieves the data for calling process's account)
So, is there any other way of process-independent user friendly name providing for workgroups ?
function GetUserNameEx(var AUserName: string; var AFriendlyUserName: string): Boolean;
var
ProcessID: Integer;
phToken, hProcess, hWindow: THandle;
cbBuf: Cardinal;
ptiUser: PTOKEN_USER;
snu: SID_NAME_USE;
szDomain, szUser : array [0..50] of Char;
chDomain, chUser : Cardinal;
UserName1: array[0..250] of Char;
FriendlyUserName: array[0..250] of Char;
Size: DWORD;
const
NameUnknown = 0; // Unknown name type.
NameFullyQualifiedDN = 1; // Fully qualified distinguished name
NameSamCompatible = 2; // Windows NT® 4.0 account name
NameDisplay = 3; // A "friendly" display name
NameUniqueId = 6; // GUID string that the IIDFromString function returns
NameCanonical = 7; // Complete canonical name
NameUserPrincipal = 8; // User principal name
NameCanonicalEx = 9;
NameServicePrincipal = 10; // Generalized service principal name
DNSDomainName = 11; // DNS domain name, plus the user name
begin
Result := False;
AUserName := '';
AFriendlyUserName := '';
hWindow := FindWindow('Progman', 'Program Manager');
if hWindow <> 0 then
begin
GetWindowThreadProcessID(hWindow, #ProcessID);
hProcess := OpenProcess(PROCESS_ALL_ACCESS, FALSE, ProcessID);
if hProcess <> 0 then
begin
if OpenProcessToken(hProcess, TOKEN_ALL_ACCESS, phToken) then
begin
if not GetTokenInformation(phToken, TokenUser, nil, 0, cbBuf) then
if GetLastError()<> ERROR_INSUFFICIENT_BUFFER then exit;
if cbBuf = 0 then exit;
GetMem(ptiUser, cbBuf);
try
chDomain := 50;
chUser := 50;
if GetTokenInformation(phToken, TokenUser, ptiUser, cbBuf, cbBuf) then
if LookupAccountSid(nil, ptiUser.User.Sid, szUser, chUser, szDomain,
chDomain, snu) then
begin
AUserName := szUser;
Result := True;
if Trim(szDomain) <> '' then
begin
FillChar(UserName1, 251, 0);
FillChar(FriendlyUserName, 251, 0);
StrCopy(UserName1, PChar(Trim(szDomain) + '\' + Trim(szUser)));
Size := 251;
//THIS CODE WORKS FOR DOMAINS ONLY, NOT FOR WORKGROUPS
if TranslateName(#UserName1, NameSamCompatible, NameDisplay, #FriendlyUserName, #Size) then
AFriendlyUserName := Trim(FriendlyUserName);
end;
end
else
raise Exception.Create('Error in GetTokenUser');
finally
FreeMem(ptiUser);
end;
end
else begin
AUserName := 'OpenProcessToken = False';
Result := False;
end
end
else begin
AUserName := '';
Result := False;
end
end
else begin
AUserName := '';
Result := False;
end
end;
GetUserNameEx respects impersonation so you can call ImpersonateLoggedOnUser with your token to get information about the user.
However, in a workgroup environment only NameSamCompatible seems to work and everything else returns ERROR_NONE_MAPPED (The user name is not available in the specified format).
Calling NetUserGetInfo also just returns a empty string for usri*_full_name.
There is also a undocumented shell function to retrieve the display name but it just falls back to GetUserName when GetUserNameEx fails.

Permissions error setting recovery option with changeserviceconfig2

I'm installing a service and wanting to set the service recovery options (using admin in an XP environment). I can change the description happily enough, but if the sfa.cActions is anything but zero it fails with a error 87 (parameter error).
//
// Actions to take on service failure
//
{$EXTERNALSYM _SC_ACTION_TYPE}
_SC_ACTION_TYPE = (SC_ACTION_NONE, SC_ACTION_RESTART, SC_ACTION_REBOOT, SC_ACTION_RUN_COMMAND);
{$EXTERNALSYM SC_ACTION_TYPE}
SC_ACTION_TYPE = _SC_ACTION_TYPE;
PServiceAction = ^TServiceAction;
{$EXTERNALSYM _SC_ACTION}
_SC_ACTION = record
aType : SC_ACTION_TYPE;
Delay : DWORD;
end;
{$EXTERNALSYM SC_ACTION}
SC_ACTION = _SC_ACTION;
TServiceAction = _SC_ACTION;
procedure TXyz_Service_Module.SetDescription(const Desc: ansistring);
var
hSCM: SC_HANDLE;
hService: SC_HANDLE;
sd: SERVICE_DESCRIPTION;
begin
hSCM := WinSvc.OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
if hSCM = 0 then Exit;
hService := WinSvc.OpenService(hSCM, PChar(Self.Name), SERVICE_CHANGE_CONFIG);
if hService = 0 then Exit;
sd.lpDescription := PAnsiChar(Desc);
ChangeServiceConfig2(hService, SERVICE_CONFIG_DESCRIPTION, #sd);
WinSvc.CloseServiceHandle(hService);
WinSvc.CloseServiceHandle(hSCM);
end;
procedure TXyz_Service_Module.SetRecovery;
var
hSCM: SC_HANDLE;
hService: SC_HANDLE;
sfa: SERVICE_FAILURE_ACTIONS;
actions: array [0 .. 2] of SC_ACTION;
begin
hSCM := WinSvc.OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
if hSCM = 0 then Exit;
hService := WinSvc.OpenService(hSCM, PChar(Self.Name), SERVICE_ALL_ACCESS);
if hService = 0 then Exit;
sfa.dwResetPeriod := 999; //INFINITE;
sfa.lpCommand := nil;
sfa.lpRebootMsg := nil;
sfa.cActions := 1;
sfa.lpsaActions := #actions[0];
actions[0].aType := SC_ACTION_RESTART;
actions[0].Delay := 5000;
(*actions[1].aType := SC_ACTION_RESTART;
actions[1].Delay := 5000;
actions[2].aType := SC_ACTION_RESTART;
actions[2].Delay := 5000;*)
if not changeserviceconfig2(hservice,SERVICE_CONFIG_FAILURE_ACTIONS,#sfa) then begin
showmessage('Error : '+inttostr(getlasterror));
end;
WinSvc.CloseServiceHandle(hService);
WinSvc.CloseServiceHandle(hSCM);
end;
procedure TXyz_Service_Module.ServiceAfterInstall(Sender: TService);
begin
self.SetDescription('Bananas are yellow');
self.SetRecovery;
end;
From the ChangeServiceConfig2() documentation:
hService [in]
A handle to the service. This handle is returned by the OpenService or CreateService function and must have the SERVICE_CHANGE_CONFIG access right. For more information, see Service Security and Access Rights.
If the service controller handles the SC_ACTION_RESTART action, hService must have the SERVICE_START access right.
So, SetRecovery() will need to use this at a minimum:
hService := WinSvc.OpenService(hSCM, PChar(Self.Name), SERVICE_CHANGE_CONFIG or SERVICE_START);
It's the enumeration value.
_SC_ACTION_TYPE = (SC_ACTION_NONE, SC_ACTION_RESTART, SC_ACTION_REBOOT, SC_ACTION_RUN_COMMAND);
needs to be
{$MinEnumSize=4}
_SC_ACTION_TYPE = (SC_ACTION_NONE, SC_ACTION_RESTART, SC_ACTION_REBOOT, SC_ACTION_RUN_COMMAND);
As recommended in the comments by David Heffernan.

Resetting a PChar variable

I don't know much about delphi win 32 programming, but I hope someone can answer my question.
I get duplicate l_sGetUniqueIdBuffer saved into the database which I want to avoid.
The l_sGetUniqueIdBuffer is actually different ( the value of l_sAuthorisationContent is xml, and I can see a different value generated by the call to getUniqueId) between rows. This problem is intermittant ( duplicates are rare...) There is only milliseconds difference between the update date between the rows.
Given:
( unnesseary code cut out)
var
l_sGetUniqueIdBuffer: PChar;
FOutputBufferSize : integer;
begin
FOutputBufferSize := 1024;
...
while( not dmAccomClaim.ADOQuClaimIdentification.Eof ) do
begin
// Get a unique id for the request
l_sGetUniqueIdBuffer := AllocMem (FOutputBufferSize);
l_returnCode := getUniqueId (m_APISessionId^, l_sGetUniqueIdBuffer, FOutputBufferSize);
dmAccomClaim.ADOQuAddContent.Active := False;
dmAccomClaim.ADOQuAddContent.Parameters.ParamByName('pContent').Value := (WideString(l_sAuthorisationContent));
dmAccomClaim.ADOQuAddContent.Parameters.ParamByName('pClaimId').Value := dmAccomClaim.ADOQuClaimIdentification.FieldByName('SB_CLAIM_ID').AsString;
dmAccomClaim.ADOQuAddContent.Parameters.ParamByName('pUniqueId').Value := string(l_sGetUniqueIdBuffer);
dmAccomClaim.ADOQuAddContent.ExecSQL;
FreeMem( l_sAuthorisationContent, l_iAuthoriseContentSize );
FreeMem( l_sGetUniqueIdBuffer, FOutputBufferSize );
end;
end;
I guess i need to know, is the value in l_sGetUniqueIdBuffer being reset for every row??
AllocMem is implemented as follows
function AllocMem(Size: Cardinal): Pointer;
begin
GetMem(Result, Size);
FillChar(Result^, Size, 0);
end;
so yes, the value that l_sGetUniqueBuffer is pointing to will always be reset to an empty string.
Debugging
var
l_sGetUniqueIdBuffer: PChar;
FOutputBufferSize : integer;
list: TStringList;
begin
FOutputBufferSize := 1024;
...
list := TStringList.Create;
try
list.Sorted := True;
while( not dmAccomClaim.ADOQuClaimIdentification.Eof ) do
begin
// Get a unique id for the request
l_sGetUniqueIdBuffer := AllocMem (FOutputBufferSize);
l_returnCode := getUniqueId (m_APISessionId^, l_sGetUniqueIdBuffer, FOutputBufferSize);
dmAccomClaim.ADOQuAddContent.Active := False;
dmAccomClaim.ADOQuAddContent.Parameters.ParamByName('pContent').Value := (WideString(l_sAuthorisationContent));
dmAccomClaim.ADOQuAddContent.Parameters.ParamByName('pClaimId').Value := dmAccomClaim.ADOQuClaimIdentification.FieldByName('SB_CLAIM_ID').AsString;
dmAccomClaim.ADOQuAddContent.Parameters.ParamByName('pUniqueId').Value := string(l_sGetUniqueIdBuffer);
if list.IndexOf(l_sGetUniqueIdBuffer) <> - 1 then
write; //***** Place a breakpoint here.
list.Add(l_sGetUniqueIdBuffer);
dmAccomClaim.ADOQuAddContent.ExecSQL;
FreeMem( l_sAuthorisationContent, l_iAuthoriseContentSize );
FreeMem( l_sGetUniqueIdBuffer, FOutputBufferSize );
end;
finally
list.Free;
end;
end;

Resources