Delphi mutual authentication - delphi

I use the WinINet library to connect to a website.
Using the Internet Explorer (Win10) it works and shows me the message to select the certificate to use.
This is the delphi code I call:
FUNCTION TRAD.lastOrganization(): Integer;
VAR
js:TlkJSONobject;
ws: TlkJSONstring;
url, resp: String;
count,statusCodeLen, bodyCodeLen: Cardinal;
header,tmp: String;
buffer, body: String;
statusCode: ARRAY [0 .. 1024] OF Char;
bodyCode: ARRAY [0 .. 1024] OF Char;
UrlHandle: HINTERNET;
BEGIN
buffer := '00000000000000000000';
url := contextUrl + '/rest/organization/count';
UrlHandle := InternetOpenUrl(NetHandle, PChar(url), nil, 0, INTERNET_FLAG_RELOAD, 0);
IF NOT ASSIGNED(UrlHandle) THEN
SHOWMESSAGE('Unable to read the amount of Organization using the URL ' + url + ': ' + SysErrorMessage(GetLastError));
statusCodeLen := Length(statusCode);
bodyCodeLen := Length(bodyCode);
count := 0;
IF HttpQueryInfo(UrlHandle, HTTP_QUERY_STATUS_CODE, #statusCode[0], statusCodeLen, count) THEN
BEGIN
buffer := statusCode;
IF buffer <> '200' THEN
BEGIN
ShowMessage('While read amount of Organization I got a status code ' + buffer + ' but 200 was expected.');
EXIT;
END;
END;
count := 0;
body := '';
REPEAT
FillChar(bodyCode, bodyCodeLen, 0);
IF NOT InternetReadFile(UrlHandle, #bodyCode[0], bodyCodeLen, count) THEN
BEGIN
ShowMessage('Problem on reading from response stream while read the amount of Organization using the URL ' + url + '.');
EXIT;
END;
IF count > 0 THEN
BEGIN
tmp := bodyCode;
body := body + LeftStr(tmp, count);
END;
UNTIL count = 0;
InternetCloseHandle(UrlHandle);
Result := strtoint(body);
END;
If I call the method, I get this message:
Buuut, using the Edge-Browser I have to specify a certificate, and it works just great.
Question
How to specify the certificate?
Edit (new informations):
If I change the code to
FUNCTION TRAD.lastOrganization(): Integer;
VAR
js:TlkJSONobject;
ws: TlkJSONstring;
url, resp: String;
count,statusCodeLen, bodyCodeLen: Cardinal;
header,tmp: String;
buffer, body: String;
statusCode: ARRAY [0 .. 1024] OF Char;
bodyCode: ARRAY [0 .. 1024] OF Char;
UrlHandle: HINTERNET;
BEGIN
buffer := '00000000000000000000';
url := contextUrl + '/rest/organization/count';
UrlHandle := InternetOpenUrl(NetHandle, PChar(url), nil, 0, INTERNET_FLAG_RELOAD, 0);
IF NOT ASSIGNED(UrlHandle) THEN
raiseLastOSError();
It shows:

Consider the use of InternetErrorDlg
Code example:
function WebSiteConnect(const UserAgent: string; const Server: string; const Resource: string;): string;
var
hInet: HINTERNET;
hConn: HINTERNET;
hReq: HINTERNET;
dwLastError:DWORD;
nilptr:Pointer;
dwRetVal:DWORD;
bLoop: boolean;
port:Integer;
begin
hInet := InternetOpen(PChar(UserAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
if hInet = nil then exit;
hConn := InternetConnect(hInet, PChar(Server), INTERNET_DEFAULT_HTTPS_PORT, nil, nil, INTERNET_SERVICE_HTTP, 0, 0);
if hConn = nil then
begin
InternetCloseHandle(hInet);
exit;
end;
hReq := HttpOpenRequest(hConn, 'GET', PChar(Resource), 'HTTP/1.0', nil, nil, INTERNET_FLAG_SECURE, 0);
if hReq = nil then
Begin
InternetCloseHandle(hConn);
InternetCloseHandle(hInet);
exit;
end;
bLoop := true;
while bLoop do
begin
if HttpSendRequest(hReq, nil, 0, nil, 0) then
dwLastError := ERROR_SUCCESS
else
dwLastError:= GetLastError();
if dwLastError = ERROR_INTERNET_CLIENT_AUTH_CERT_NEEDED then
begin
dwRetVal:= InternetErrorDlg(application.handle, hReq, dwLastError,
FLAGS_ERROR_UI_FILTER_FOR_ERRORS or
FLAGS_ERROR_UI_FLAGS_GENERATE_DATA or
FLAGS_ERROR_UI_FLAGS_CHANGE_OPTIONS,
nilptr );
if dwRetVal = ERROR_INTERNET_FORCE_RETRY then
continue
else // CANCEL button
begin
InternetCloseHandle(hReq);
InternetCloseHandle(hConn);
InternetCloseHandle(hInet);
exit;
end;
end
else
bLoop := false;
end;
Result:= ...
end;

Using WinHTTP (You can do the same with WinInetHTTP) you can set the certificate like this via ActiveX :
// Instantiate a WinHttpRequest object.
var HttpReq = new ActiveXObject("WinHttp.WinHttpRequest.5.1");
// Open an HTTP connection.
HttpReq.Open("GET", "https://www.fabrikam.com/", false);
// Select a client certificate.
HttpReq.SetClientCertificate(
"LOCAL_MACHINE\\Personal\\My Middle-Tier Certificate");
// Send the HTTP Request.
HttpReq.Send();
So that easy with ActiveX but it's not really what you want (i gave you the example as illustration). So with the windows API, WinHTTP enables you to select and send a certificate from a local certificate store. The following code example shows how to open a certificate store and locate a certificate based on subject name after the ERROR_WINHTTP_CLIENT_AUTH_CERT_NEEDED error has been returned.
if( !WinHttpReceiveResponse( hRequest, NULL ) )
{
if( GetLastError( ) == ERROR_WINHTTP_CLIENT_AUTH_CERT_NEEDED )
{
//MY is the store the certificate is in.
hMyStore = CertOpenSystemStore( 0, TEXT("MY") );
if( hMyStore )
{
pCertContext = CertFindCertificateInStore( hMyStore,
X509_ASN_ENCODING | PKCS_7_ASN_ENCODING,
0,
CERT_FIND_SUBJECT_STR,
(LPVOID) szCertName, //Subject string in the certificate.
NULL );
if( pCertContext )
{
WinHttpSetOption( hRequest,
WINHTTP_OPTION_CLIENT_CERT_CONTEXT,
(LPVOID) pCertContext,
sizeof(CERT_CONTEXT) );
CertFreeCertificateContext( pCertContext );
}
CertCloseStore( hMyStore, 0 );
// NOTE: Application should now resend the request.
}
}
}

Related

How do I authenticate proxy server in WinInet for HTTPS?

According to Microsoft-Support: How To Handle Proxy Authorization with WinInet
and other Delphi examples (http://forum.codecall.net/topic/51366-internetopen-tthreads-maxconnectionsperserver/, https://pastebin.com/f1ea3a752), I wrote following test code to try out the proper way to access a https page through an authenticated proxy server:
program Project35;
{$APPTYPE CONSOLE}
uses
SysUtils, WinInet, Windows, Classes;
Function sslGet(Const AServer, AUrl : string): AnsiString;
var
aBuffer : Array[0..4096] of Char;
BufStream : TMemoryStream;
sMethod : AnsiString;
BytesRead : Cardinal;
pSession : HINTERNET;
pConnection : HINTERNET;
pRequest : HINTERNET;
LUsername: string;
LPassword: string;
LProxy, LBypass: string;
LAgent: string;
LStatusCode, LStatusLen, LIndex : DWORD;
begin
Result := '';
LUsername := 'User-002' ;
LPassword := 'test2';
LProxy := 'myproxyserver:808';//https=https://
LBypass := '<local>';
LAgent := 'Bo-Test';
//pSession := InternetOpen(PChar(LAgent), INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);
pSession := InternetOpen(PChar(LAgent), INTERNET_OPEN_TYPE_PROXY , PChar(LProxy), PChar(LBypass), 0);
//pSession := InternetOpen(PChar(LAgent), INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY , nil, nil, 0);
if Assigned(pSession) then
try
// pConnection := InternetConnect(pSession, PChar(AServer), INTERNET_DEFAULT_HTTPS_PORT, PChar(LUsername), PChar(LPassword), INTERNET_SERVICE_HTTP, 0, 0);
pConnection := InternetConnect(pSession, PChar(AServer), INTERNET_DEFAULT_HTTPS_PORT, nil, nil, INTERNET_SERVICE_HTTP, 0, 0);
if Assigned(pConnection) then
try
sMethod := 'GET';
pRequest := HTTPOpenRequest(pConnection, PChar(sMethod), PChar(AURL), nil, nil, nil,
INTERNET_FLAG_SECURE or
INTERNET_FLAG_KEEP_CONNECTION or
INTERNET_FLAG_NO_CACHE_WRITE or
INTERNET_FLAG_PRAGMA_NOCACHE or
INTERNET_FLAG_NO_AUTH or
INTERNET_FLAG_IGNORE_CERT_CN_INVALID or
INTERNET_FLAG_IGNORE_CERT_DATE_INVALID or
INTERNET_FLAG_NO_UI or
INTERNET_FLAG_IGNORE_REDIRECT_TO_HTTPS or
SECURITY_FLAG_IGNORE_UNKNOWN_CA, 0); //or INTERNET_FLAG_NO_AUTH
if Assigned(pRequest) then
try
if HTTPSendRequest(pRequest, nil, 0, nil, 0) then
begin
LStatusLen := SizeOf(LStatusCode);
LIndex := 0;
// expecting a 407 returned
HttpQueryInfo(pRequest, HTTP_QUERY_STATUS_CODE or HTTP_QUERY_FLAG_NUMBER,
#LStatusCode, LStatusLen, LIndex);
Write('Status code=');
writeln(LStatusCode);
// resend after 407
InternetSetOption(pRequest, INTERNET_OPTION_PROXY_USERNAME, PChar(LUsername) , length(LUsername));
InternetSetOption(pRequest, INTERNET_OPTION_PROXY_PASSWORD, PChar(LPassword), length(LPassword));
HTTPSendRequest(pRequest, nil, 0, nil, 0);
HttpQueryInfo(pRequest, HTTP_QUERY_STATUS_CODE or HTTP_QUERY_FLAG_NUMBER,
#LStatusCode, LStatusLen, LIndex);
Write('Resend status code=');
writeln(LStatusCode);
BufStream := TMemoryStream.Create;
try
while InternetReadFile(pRequest, #aBuffer, SizeOf(aBuffer), BytesRead) do
begin
if (BytesRead = 0) then Break;
BufStream.Write(aBuffer, BytesRead);
end;
aBuffer[0] := #0;
BufStream.Write(aBuffer, 1);
Result := PChar(BufStream.Memory);
finally
FreeAndNil(BufStream);
end;
end
else begin
Writeln(GetLastError());
end;
finally
InternetCloseHandle(pRequest);
end;
finally
InternetCloseHandle(pConnection);
end;
finally
InternetCloseHandle(pSession);
end;
end;
var
StopEnter: string;
begin
try
// the wsdl is only available with ssl, i.e., https://services.staging.referralnet.com.au/services/Referral_Service_51?wsdl
// it is invalid for http://services.staging.referralnet.com.au/services/Referral_Service_51?wsdl
Writeln(sslGet('services.staging.referralnet.com.au', '/services/Referral_Service_51?wsdl'));
Write('Press Enter to stop ...');
Readln(StopEnter);
except
on E:Exception do
Writeln(E.Classname, ': ', E.Message);
end;
end.
I am using CCProxy as the proxy server for this testing.
I tried with two machines, one modified the hosts file so that the server of the wsdl page is pointing to 127.0.0.1, another one modified its firewall, so all the traffic to the server is blocked.
Both testings returned two 407 code, i.e., original and resend request both failed with 407.
What could be wrong? Or somebody can point me to an working example?
Take a look at how the THttpRIo component handles this. Just follow the proxy property usage in the code.

delphi Get and compare big text file from web with string

I have one big text file with 95000+ lines on web
Now for example:
I have one string
I want to match that string in that file
and read that whole line where that string is placed in file
I am using wininet
I can load whole file in to string
but while matching it takes alot of time and gui hangs
is there anyway to do it more faster ?
edit:
Here is code i m using to get urlcontents from web
in button1
var
s:string;
begin
//1- as file is big it takes alot of time :/
S := GetUrlContent('web url example');
if (Pos('string i want to search', s)> 0) then
begin
mmo1.lines.add('Found');
//2- now how can i show extact line that contains string
end;
end;
//----------------------------------------------------
function GetUrlContent(const Url: string): string;
var
NetHandle: HINTERNET;
UrlHandle: HINTERNET;
Buffer: array[0..1024] of Char;
BytesRead: dWord;
begin
Result := '';
NetHandle := InternetOpen('Delphi 5.x', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
if Assigned(NetHandle) then
begin
UrlHandle := InternetOpenUrl(NetHandle, PChar(Url), nil, 0, INTERNET_FLAG_RELOAD, 0);
if Assigned(UrlHandle) then
{ UrlHandle valid? Proceed with download }
begin
FillChar(Buffer, SizeOf(Buffer), 0);
repeat
Result := Result + Buffer;
FillChar(Buffer, SizeOf(Buffer), 0);
InternetReadFile(UrlHandle, #Buffer, SizeOf(Buffer), BytesRead);
until BytesRead = 0;
InternetCloseHandle(UrlHandle);
end
else
{ UrlHandle is not valid. Raise an exception. }
raise Exception.CreateFmt('Cannot open URL %s', [Url]);
InternetCloseHandle(NetHandle);
end
else
{ NetHandle is not valid. Raise an exception }
raise Exception.Create('Unable to initialize');
end;

Check if everyone may read/write to a directory

We are facing the problem, that different user groups shall be able to read and write files from a common data directory (e.g. c:\ProgramData\xyz).
The data is written from different sources e.g. a service writes files into it and a user shall be able to change it's content later on.
The problem now is that this only works if "everybody" is allowed to read/write/change
files in that directory (und subdirs).
What I want to check in the installer is if all users are allowed to do so aka. check if the "every users" group (or "Jeder" group in german) is in the access list.
I have only basic knowledge about ACL and can change that in the explorer but I would need a few lines of code which push me into the right direction (in Delphi).
many thanks
Mike
I think it's not a Delphi but WinAPI question. Delphi doesn't have any special facilities to make this easier AFAIK.
Getting information from an ACL says you need to do GetSecurityInfo on an open handle, then GetEffectiveRightsFromACL on an ACL you get.
You specify a trustee, which can be by name, but better use SID. Name for "Everyone" can change, but there's a special SID for it which is valid on any PC, google it. Okay, here it is: "(S-1–1–0)". Or you can use CreateWellKnownSid and give it WinWorldSid to get the same SID (more proper but longer way).
All of that from five minutes of googling so watch out for mistakes.
Alright, here's some code.
function ConvertStringSidToSid(StringSid: PWideChar; var Sid: PSID): boolean; stdcall; external advapi32 name 'ConvertStringSidToSidW';
function AclGetEffectiveRights(const path, sid: string): cardinal;
var h: THandle; //handle to our directory
err: integer;
dacl: PACL; //access control list for the object
secdesc: pointer;
tr: TRUSTEE;
bsid: PSid;
begin
Result := 0;
//Open directory
h := CreateFile(PChar(path), GENERIC_READ, FILE_SHARE_READ, nil,
OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_BACKUP_SEMANTICS, 0);
//we need FILE_FLAG_BACKUP_SEMANTICS to open a directory
if h=INVALID_HANDLE_VALUE then RaiseLastOsError();
try
bsid := nil;
//Query access control list for a directory -- the list you see in the properties box
err := GetSecurityInfo(h, SE_FILE_OBJECT, DACL_SECURITY_INFORMATION,
nil, nil, #dacl, nil, secdesc);
//GetSecurityInfo can return many things but we only need DACL,
//and we are required to also get a security descriptor
if err<>ERROR_SUCCESS then
raise Exception.CreateFmt('Cannot retrieve DACL: error %d',[err]);
try
//Convert string sid to binary sid
if not ConvertStringSidToSid(PChar(sid), bsid) then
RaiseLastOsError();
//Query effective rights for a trustee
BuildTrusteeWithSid(#tr, bsid);
err := GetEffectiveRightsFromAcl(dacl^, tr, Result);
if err<>ERROR_SUCCESS then
raise Exception.CreateFmt('Cannot calculate effective rights: error %d',[err]);
finally
//Documentation says to free some resources this way when we're done with it.
LocalFree(NativeUint(bsid));
LocalFree(NativeUint(secdesc));
end;
finally
CloseHandle(h);
end;
end;
It's used like this:
var rights,test: cardinal;
rights := AclGetEffectiveRights('C:\My\Folder','S-1-1-0');
//List rights you want tested
test := FILE_LIST_DIRECTORY + FILE_ADD_FILE + FILE_ADD_SUBDIRECTORY
+ FILE_READ_EA + FILE_WRITE_EA + FILE_TRAVERSE + FILE_DELETE_CHILD;
Result := (rights and test) = test;
Might not work; gives ACCESS_DENIED on my PC but that's probably because of my complicated domain situation. Anyway that's something for a start.
So.. The above version worked... until Windows Update 1903 hit me and GetEffectiveRightsFromAcl always resulted in an error ERROR_NO_SUCH_DOMAIN (which is obscure since there is no Domain whatsoever involved here).
So I needed to switch to the following procedure:
// ###########################################
// ### translated and extended from https://learn.microsoft.com/de-de/windows/win32/api/aclapi/nf-aclapi-geteffectiverightsfromacla
procedure DisplayAccessMask(Mask : ACCESS_MASK );
begin
{
// This evaluation of the ACCESS_MASK is an example.
// Applications should evaluate the ACCESS_MASK as necessary.
}
if (((Mask and GENERIC_ALL) = GENERIC_ALL)
or ((Mask and FILE_ALL_ACCESS) = FILE_ALL_ACCESS))
then
begin
OutputDebugString( 'Full control');
exit;
end;
if (((Mask and GENERIC_READ) = GENERIC_READ)
or ((Mask and FILE_GENERIC_READ) = FILE_GENERIC_READ))
then
OutputDebugString( 'Read');
if (((Mask and GENERIC_WRITE) = GENERIC_WRITE)
or ((Mask and FILE_GENERIC_WRITE) = FILE_GENERIC_WRITE))
then
OutputDebugString('Write');
if (((Mask and GENERIC_EXECUTE) = GENERIC_EXECUTE)
or ((Mask and FILE_GENERIC_EXECUTE) = FILE_GENERIC_EXECUTE))
then
OutputDebugString('Execute');
end;
function CheckMask( MASK : ACCESS_MASK; refMask : ACCESS_MASK ) : boolean;
var msk : ACCESS_MASK;
begin
msk := 0;
if (((Mask and GENERIC_READ) = GENERIC_READ)
or ((Mask and FILE_GENERIC_READ) = FILE_GENERIC_READ))
then
msk := msk or FILE_GENERIC_READ;
if (((Mask and GENERIC_WRITE) = GENERIC_WRITE)
or ((Mask and FILE_GENERIC_WRITE) = FILE_GENERIC_WRITE))
then
msk := msk or FILE_GENERIC_WRITE;
if (((Mask and GENERIC_EXECUTE) = GENERIC_EXECUTE)
or ((Mask and FILE_GENERIC_EXECUTE) = FILE_GENERIC_EXECUTE))
then
msk := msk or FILE_GENERIC_EXECUTE;
Result := (msk and refMask) = refMask;
end;
function GetAccess(hAuthzClient :AUTHZ_CLIENT_CONTEXT_HANDLE; psd : PSECURITY_DESCRIPTOR) : BOOL;
var AccessRequest : AUTHZ_ACCESS_REQUEST;
AccessReply : AUTHZ_ACCESS_REPLY;
buffer : Array[0..1023] of Byte;
begin
FillChar(AccessRequest, sizeof(AccessRequest), 0);
FillChar(AccessReply, sizeof(AccessReply), 0);
FillChar(buffer, sizeof(buffer), 0);
AccessRequest.DesiredAccess := MAXIMUM_ALLOWED;
AccessRequest.PrincipalSelfSid := nil;
AccessRequest.ObjectTypeList := nil;
AccessRequest.ObjectTypeListLength := 0;
AccessRequest.OptionalArguments := nil;
AccessReply.ResultListLength := 1;
AccessReply.GrantedAccessMask := PACCESS_MASK( LongWord(#Buffer[0]));
AccessReply.Error := PDWORD( LongWord( AccessReply.GrantedAccessMask ) + sizeof(Access_Mask));
Result := AuthzAccessCheck( 0,
hAuthzClient,
#AccessRequest,
0,
psd,
nil,
0,
#AccessReply,
nil);
if Result then
begin
DisplayAccessMask( AccessReply.GrantedAccessMask^ );
Result := CheckMask( AccessReply.GrantedAccessMask^, FILE_GENERIC_WRITE or FILE_GENERIC_READ );
end
else
RaiseLastOSError;
end;
function ConvertStringSidToSid(StringSid: PWideChar; var Sid: PSID): boolean; stdcall; external advapi32 name 'ConvertStringSidToSidW';
function ConvertNameToBinarySid(pAccountName : PCHAR): PSID ;
var pDomainName : PChar;
dwDomainNameSize : DWord;
aSID : PSID;
dwSIDSIZE : DWORD;
sidType : SID_NAME_USE;
begin
pDomainName := nil;
dwDomainNameSize := 0;
aSID := nil;
LookupAccountName( nil, pAccountName, aSID, dwSIDSIZE, pDomainName, dwDomainNameSize, sidType);
aSid := Pointer( LocalAlloc( LPTR, dwSIDSIZE*sizeof(char)) );
pDomainName := Pointer( LocalAlloc(LPTR, dwDomainNameSize*sizeof(char)) );
if not LookupAccountName( nil, pAccountName, aSID, dwSIDSIZE, pDomainName, dwDomainNameSize, sidType) then
begin
LocalFree( Cardinal(aSID) );
Result := nil;
end
else
begin
Result := aSid;
end;
LocalFree( Cardinal(pDomainName) );
end;
function GetEffectiveRightsForSID(hManager :AUTHZ_RESOURCE_MANAGER_HANDLE;
psd : PSECURITY_DESCRIPTOR;
sid : PChar) : BOOL;
var asid : PSID;
bResult : BOOL;
unusedID : LUID;
hAuthzClientContext : AUTHZ_CLIENT_CONTEXT_HANDLE;
begin
Result := False;
asid := nil;
hAuthzClientContext := 0;
FillChar(unusedID, sizeof(unusedID), 0);
if not ConvertStringSidToSid(sid, asid) then
RaiseLastOsError();
// asid := ConvertNameToBinarySid('rabatscher');
if asid = nil then
RaiseLastOSError;
try
if asid <> nil then
begin
bResult := AuthzInitializeContextFromSid( 0, aSid, hManager, nil, unusedId, nil, #hAuthzClientContext );
try
if bResult then
Result := GetAccess(hAuthzClientContext, psd);
finally
if hAuthzClientContext <> 0 then
AuthzFreeContext(hAuthzClientContext);
end;
end;
finally
if asid <> nil then
LocalFree(LongWord(asid));
end;
end;
function UseAuthzSolution( psd : PSECURITY_DESCRIPTOR; const sid : string = 'S-1-1-0') : boolean;
var hManager : AUTHZ_RESOURCE_MANAGER_HANDLE;
bResult : BOOL;
pSid : PChar;
begin
bResult := AuthzInitializeResourceManager(AUTHZ_RM_FLAG_NO_AUDIT,
nil, nil, nil, nil, #hManager);
if bResult then
begin
pSid := PChar(sid);
bResult := GetEffectiveRightsForSID(hManager, psd, psid);
AuthzFreeResourceManager(hManager);
end;
Result := bResult;
end;
function GetSecurityInfo(handle: THandle; ObjectType: SE_OBJECT_TYPE;
SecurityInfo: SECURITY_INFORMATION; ppsidOwner, ppsidGroup: PPSID; ppDacl, ppSacl: PACL;
var pSecurityDescriptor: PSECURITY_DESCRIPTOR): DWORD; stdcall; external 'ADVAPI32.DLL' name 'GetSecurityInfo'; {use localfree to release ppSecurityDescriptor}
function CheckDirectoryAccess( path : string ) : boolean;
var dw : DWORD;
apacl : PACL;
psd : PSECURITY_DESCRIPTOR;
apSID : PSID;
h : THandle;
begin
try
apSID := nil;
//Open directory
h := CreateFile(PChar(path), GENERIC_READ, FILE_SHARE_READ, nil,
OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_BACKUP_SEMANTICS, 0);
//we need FILE_FLAG_BACKUP_SEMANTICS to open a directory
if h = INVALID_HANDLE_VALUE then
RaiseLastOsError();
try
//Query access control list for a directory -- the list you see in the properties box
dw := GetSecurityInfo(h, SE_FILE_OBJECT, DACL_SECURITY_INFORMATION or OWNER_SECURITY_INFORMATION or GROUP_SECURITY_INFORMATION,
nil, nil, #apacl, nil, psd);
if dw <> ERROR_SUCCESS then
RaiseLastOSError;
try
Result := UseAuthzSolution(psd);
finally
if apSID <> nil then
LocalFree(NativeUint(apSID));
LocalFree(NativeUint(psd));
end;
finally
CloseHandle(h);
end;
except
on E : Exception do
begin
Result := False;
end;
end;
end;
Note that there are a few changes so the procedure works:
GetSecurityInfo (from the above procedure) needs the parameter DACL_SECURITY_INFORMATION or OWNER_SECURITY_INFORMATION or GROUP_SECURITY_INFORMATION (not only DACL_SECURITY_INFORMATION) otherwise you get an Error 87 in AuthzAccessCheck!
In addition you need to check out the JWA headers from the jedi library.
Hope that helps other people too.

Using WinInet to identify total file size before downloading it

I got the source below from a third-party site explaining how to download a file from the internet using WinInet. I'm not too familiar with API, and I took at look at the WinInet unit but did not see any API calls like what I need.
What I'm doing is adding the ability to report back progress of downloading a file. This procedure I've already wrapped inside of a TThread and everything works fine. However, just one missing piece: Finding the total size of the source file before downloading.
See below where I have a comment //HOW TO GET TOTAL SIZE? This is where I need to find out what is the total size of the file BEFORE I begin downloading it. How do I go about doing this? Because this code seems to not know the size of the file until it's done being downloaded - and that makes this addition irrelevant.
procedure TInetThread.Execute;
const
BufferSize = 1024;
var
hSession, hURL: HInternet;
Buffer: array[1..BufferSize] of Byte;
BufferLen: DWORD;
f: File;
S: Bool;
D: Integer;
T: Integer;
procedure DoWork(const Amt: Integer);
begin
if assigned(FOnWork) then
FOnWork(Self, FSource, FDest, Amt, T);
end;
begin
S:= False;
try
try
if not DirectoryExists(ExtractFilePath(FDest)) then begin
ForceDirectories(ExtractFilePath(FDest));
end;
hSession:= InternetOpen(PChar(FAppName), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
try
hURL:= InternetOpenURL(hSession, PChar(FSource), nil, 0, 0, 0);
try
AssignFile(f, FDest);
Rewrite(f, 1);
T:= 0; //HOW TO GET TOTAL SIZE?
D:= 0;
DoWork(D);
repeat
InternetReadFile(hURL, #Buffer, SizeOf(Buffer), BufferLen);
BlockWrite(f, Buffer, BufferLen);
D:= D + BufferLen;
DoWork(D);
until BufferLen = 0;
CloseFile(f);
S:= True;
finally
InternetCloseHandle(hURL);
end
finally
InternetCloseHandle(hSession);
end;
except
on e: exception do begin
S:= False;
end;
end;
finally
if assigned(FOnComplete) then
FOnComplete(Self, FSource, FDest, S);
end;
end;
You can use the HEAD method and check the Content-Length to retrieve the file size of a remote file
Check these two Methods
WinInet
If you want execute a HEAD method you must use the HttpOpenRequest, HttpSendRequest and HttpQueryInfo WinInet functions .
uses
SysUtils,
Windows,
WinInet;
function GetWinInetError(ErrorCode:Cardinal): string;
const
winetdll = 'wininet.dll';
var
Len: Integer;
Buffer: PChar;
begin
Len := FormatMessage(
FORMAT_MESSAGE_FROM_HMODULE or FORMAT_MESSAGE_FROM_SYSTEM or
FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_IGNORE_INSERTS or FORMAT_MESSAGE_ARGUMENT_ARRAY,
Pointer(GetModuleHandle(winetdll)), ErrorCode, 0, #Buffer, SizeOf(Buffer), nil);
try
while (Len > 0) and {$IFDEF UNICODE}(CharInSet(Buffer[Len - 1], [#0..#32, '.'])) {$ELSE}(Buffer[Len - 1] in [#0..#32, '.']) {$ENDIF} do Dec(Len);
SetString(Result, Buffer, Len);
finally
LocalFree(HLOCAL(Buffer));
end;
end;
procedure ParseURL(const lpszUrl: string; var Host, Resource: string);
var
lpszScheme : array[0..INTERNET_MAX_SCHEME_LENGTH - 1] of Char;
lpszHostName : array[0..INTERNET_MAX_HOST_NAME_LENGTH - 1] of Char;
lpszUserName : array[0..INTERNET_MAX_USER_NAME_LENGTH - 1] of Char;
lpszPassword : array[0..INTERNET_MAX_PASSWORD_LENGTH - 1] of Char;
lpszUrlPath : array[0..INTERNET_MAX_PATH_LENGTH - 1] of Char;
lpszExtraInfo : array[0..1024 - 1] of Char;
lpUrlComponents : TURLComponents;
begin
ZeroMemory(#lpszScheme, SizeOf(lpszScheme));
ZeroMemory(#lpszHostName, SizeOf(lpszHostName));
ZeroMemory(#lpszUserName, SizeOf(lpszUserName));
ZeroMemory(#lpszPassword, SizeOf(lpszPassword));
ZeroMemory(#lpszUrlPath, SizeOf(lpszUrlPath));
ZeroMemory(#lpszExtraInfo, SizeOf(lpszExtraInfo));
ZeroMemory(#lpUrlComponents, SizeOf(TURLComponents));
lpUrlComponents.dwStructSize := SizeOf(TURLComponents);
lpUrlComponents.lpszScheme := lpszScheme;
lpUrlComponents.dwSchemeLength := SizeOf(lpszScheme);
lpUrlComponents.lpszHostName := lpszHostName;
lpUrlComponents.dwHostNameLength := SizeOf(lpszHostName);
lpUrlComponents.lpszUserName := lpszUserName;
lpUrlComponents.dwUserNameLength := SizeOf(lpszUserName);
lpUrlComponents.lpszPassword := lpszPassword;
lpUrlComponents.dwPasswordLength := SizeOf(lpszPassword);
lpUrlComponents.lpszUrlPath := lpszUrlPath;
lpUrlComponents.dwUrlPathLength := SizeOf(lpszUrlPath);
lpUrlComponents.lpszExtraInfo := lpszExtraInfo;
lpUrlComponents.dwExtraInfoLength := SizeOf(lpszExtraInfo);
InternetCrackUrl(PChar(lpszUrl), Length(lpszUrl), ICU_DECODE or ICU_ESCAPE, lpUrlComponents);
Host := lpszHostName;
Resource := lpszUrlPath;
end;
function GetRemoteFileSize(const Url : string): Integer;
const
sUserAgent = 'Mozilla/5.001 (windows; U; NT4.0; en-US; rv:1.0) Gecko/25250101';
var
hInet : HINTERNET;
hConnect : HINTERNET;
hRequest : HINTERNET;
lpdwBufferLength: DWORD;
lpdwReserved : DWORD;
ServerName: string;
Resource: string;
ErrorCode : Cardinal;
begin
ParseURL(Url,ServerName,Resource);
Result:=0;
hInet := InternetOpen(PChar(sUserAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
if hInet=nil then
begin
ErrorCode:=GetLastError;
raise Exception.Create(Format('InternetOpen Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
end;
try
hConnect := InternetConnect(hInet, PChar(ServerName), INTERNET_DEFAULT_HTTP_PORT, nil, nil, INTERNET_SERVICE_HTTP, 0, 0);
if hConnect=nil then
begin
ErrorCode:=GetLastError;
raise Exception.Create(Format('InternetConnect Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
end;
try
hRequest := HttpOpenRequest(hConnect, PChar('HEAD'), PChar(Resource), nil, nil, nil, 0, 0);
if hRequest<>nil then
begin
try
lpdwBufferLength:=SizeOf(Result);
lpdwReserved :=0;
if not HttpSendRequest(hRequest, nil, 0, nil, 0) then
begin
ErrorCode:=GetLastError;
raise Exception.Create(Format('HttpOpenRequest Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
end;
if not HttpQueryInfo(hRequest, HTTP_QUERY_CONTENT_LENGTH or HTTP_QUERY_FLAG_NUMBER, #Result, lpdwBufferLength, lpdwReserved) then
begin
Result:=0;
ErrorCode:=GetLastError;
raise Exception.Create(Format('HttpQueryInfo Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
end;
finally
InternetCloseHandle(hRequest);
end;
end
else
begin
ErrorCode:=GetLastError;
raise Exception.Create(Format('HttpOpenRequest Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
end;
finally
InternetCloseHandle(hConnect);
end;
finally
InternetCloseHandle(hInet);
end;
end;
Indy
Also check this code using indy.
function GetRemoteFilesize(const Url :string) : Integer;
var
Http: TIdHTTP;
begin
Http := TIdHTTP.Create(nil);
try
Http.Head(Url);
result:= Http.Response.ContentLength;
finally
Http.Free;
end;
end;
Answering the question of how to get a download size with WinInet. This is out of one of my file downloaders that is based on WinInet.
This is the method I use to get the download size:
function TWebDownloader.GetContentLength(URLHandle: HINTERNET): Int64;
// returns the expected download size. Returns -1 if one not provided
var
SBuffer: Array[1..20] of char;
SBufferSize: Integer;
srv: integer;
begin
srv := 0;
SBufferSize := 20;
if HttpQueryInfo(URLHandle, HTTP_QUERY_CONTENT_LENGTH, #SBuffer, SBufferSize, srv) then
Result := StrToFloat(String(SBuffer))
else
Result := -1;
end;
Use of this method requires an open request handle, and does NOT require reading any of the data:
URLHandle := HttpOpenRequest(ConnectHandle, 'GET', Pchar(sitepath), nil,
nil, nil, INTERNET_FLAG_NO_CACHE_WRITE, 0);
...
DownloadSize := GetContentLength(URLHandle);
HTH
after fixing the types it looks better like this:
function GetContentLength(URLHandle:HINTERNET):Int64;
// returns the expected download size. Returns -1 if one not provided
var
SBufferSize, srv:Cardinal;
begin
srv:=0;
SBufferSize:=20;
if Not HttpQueryInfo(URLHandle, HTTP_QUERY_CONTENT_LENGTH or HTTP_QUERY_FLAG_NUMBER, {#SBuffer} #Result, SBufferSize, srv) then Result:=-1;
end;
to call it:
{get the file handle}
hURL:=InternetOpenURL(hSession, PChar(URL), nil, 0, 0, 0);
if hURL=Nil then
begin
InternetCloseHandle(hSession);
ShowMessage('The link is incorrect!');
exit;
end;
{get the file size}
filesize:=GetContentLength(hURL);

How to send a HTTP Post Request in Delphi 2010 using WinInet [duplicate]

This question already has answers here:
How to send a HTTP POST Request in Delphi using WinInet api
(3 answers)
Closed 9 years ago.
I want to send a HTTP Post Request in Delphi 2010 using WinInet, but my script doesn't work ;/
It's my Delphi script:
uses WinInet;
procedure TForm1.Button1Click(Sender: TObject);
var
hNet,hURL,hRequest: HINTERNET;
begin
hNet := InternetOpen(PChar('User Agent'),INTERNET_OPEN_TYPE_PRECONFIG or INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
if Assigned(hNet) then
begin
try
hURL := InternetConnect(hNet,PChar('http://localhost/delphitest.php'),INTERNET_DEFAULT_HTTP_PORT,nil,nil,INTERNET_SERVICE_HTTP,0,DWORD(0));
if(hURL<>nil) then
hRequest := HttpOpenRequest(hURL, 'POST', PChar('test=test'),'HTTP/1.0',PChar(''), nil, INTERNET_FLAG_RELOAD or INTERNET_FLAG_PRAGMA_NOCACHE,0);
if(hRequest<>nil) then
HttpSendRequest(hRequest, nil, 0, nil, 0);
InternetCloseHandle(hNet);
except
ShowMessage('error');
end
end;
end;
and my PHP script:
$data = $_POST['test'];
$file = "test.txt";
$fp = fopen($file, "a");
flock($fp, 2);
fwrite($fp, $data);
flock($fp, 3);
fclose($fp);
Major problems:
The second parameter of InternetConnect should contain only the name of the server, not the entire URL of the server-side script.
The third parameter of HttpOpenRequest should be the file name (URL) of the script, not the POST data!
The actual POST data should be the forth parameter of HttpSendRequest.
Minor problems
INTERNET_OPEN_TYPE_PRECONFIG or INTERNET_OPEN_TYPE_PRECONFIG: It is sufficient with INTERNET_OPEN_TYPE_PRECONFIG.
DWORD(0) is overkill. 0 is enough.
Sample Code
I use the following code to POST data:
procedure WebPostData(const UserAgent: string; const Server: string; const Resource: string; const Data: AnsiString); overload;
var
hInet: HINTERNET;
hHTTP: HINTERNET;
hReq: HINTERNET;
const
accept: packed array[0..1] of LPWSTR = (PChar('*/*'), nil);
header: string = 'Content-Type: application/x-www-form-urlencoded';
begin
hInet := InternetOpen(PChar(UserAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
try
hHTTP := InternetConnect(hInet, PChar(Server), INTERNET_DEFAULT_HTTP_PORT, nil, nil, INTERNET_SERVICE_HTTP, 0, 1);
try
hReq := HttpOpenRequest(hHTTP, PChar('POST'), PChar(Resource), nil, nil, #accept, 0, 1);
try
if not HttpSendRequest(hReq, PChar(header), length(header), PChar(Data), length(Data)) then
raise Exception.Create('HttpOpenRequest failed. ' + SysErrorMessage(GetLastError));
finally
InternetCloseHandle(hReq);
end;
finally
InternetCloseHandle(hHTTP);
end;
finally
InternetCloseHandle(hInet);
end;
end;
For instance:
WebPostData('My UserAgent', 'www.rejbrand.se', 'mydir/myscript.asp', 'value=5');
Update in response to answer by OP
To read data from the Internet, use InternetReadFile function. I use the following code to read a small (one-line) text file from the Internet:
function WebGetData(const UserAgent: string; const Server: string; const Resource: string): string;
var
hInet: HINTERNET;
hURL: HINTERNET;
Buffer: array[0..1023] of AnsiChar;
i, BufferLen: cardinal;
begin
result := '';
hInet := InternetOpen(PChar(UserAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
try
hURL := InternetOpenUrl(hInet, PChar('http://' + Server + Resource), nil, 0, 0, 0);
try
repeat
InternetReadFile(hURL, #Buffer, SizeOf(Buffer), BufferLen);
if BufferLen = SizeOf(Buffer) then
result := result + AnsiString(Buffer)
else if BufferLen > 0 then
for i := 0 to BufferLen - 1 do
result := result + Buffer[i];
until BufferLen = 0;
finally
InternetCloseHandle(hURL);
end;
finally
InternetCloseHandle(hInet);
end;
end;
Sample usage:
WebGetData('My UserAgent', 'www.rejbrand.se', '/MyDir/update/ver.txt')
This function thus only reads data, with no prior POST. However, the InternetReadFile function can also be used with a handle created by HttpOpenRequest, so it will work in your case also. You do know that the WinInet reference is MSDN, right? All Windows API functions are described in detail there, for instance InternetReadFile.
var
BufferIn : INTERNET_BUFFERS;
Buffer: array[0..1024] of Byte;
FTmp: TSomeStream:
FURL: string;
...
begin
... // Create FTmp, set FUrl, ...
NetHandle := InternetOpen( 'Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:1.9.1.3) Gecko/20090824 Firefox/3.5.3',
INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
UrlHandle := HttpOpenRequest(NetHandle, 'POST', PChar(FURL), nil, nil, nil, INTERNET_FLAG_NO_CACHE_WRITE, 0);
... // Check handles, etc
try
BufferIn.dwBufferTotal := FTmp.Size;
if not HttpSendRequestEx(UrlHandle, #BufferIn, nil, 0, 0) then
raise Exception.CreateFmt('Error on HttpSendRequestEx %d\n', [GetLastError()]);
size := FTmp.Read(Buffer, 1024);
InternetWriteFile(UrlHandle, #Buffer, size, BytesWritten);
while (BytesWritten = size) and (BytesWritten > 0) do
begin
size := FTmp.Read(Buffer, 1024);
InternetWriteFile(UrlHandle, #Buffer, size, BytesWritten);
end;
finally
FTmp.Free;
InternetCloseHandle(UrlHandle);
InternetCloseHandle(NetHandle);
end;
There is a library (called 'HTTPGet component for Delphi 32') on http://www.utilmind.com. It installs a visual control into your component palette.
It does exactly what you want, so you may want to take a look.

Resources