CancelLock include
From 40tude Dialog Wiki
Cancel-Lock (Include-File)
This little script provide support for the Cancel-Lock Header (Whats Cancel-Lock?).
Works with version 2.0.12.88 and later. Uses CryptoApi, so will work on Windows 98 and later.
Install & Setup the script
Please note that this script is an include-file!. You have to copy the following script inside a new custom script (for example "CancelLock_include") and safe it. Please don't compile this custom script! After that you have to add the following lines to your OnBeforeSending-Script:
{$I CancelLock_include.ds}
and
CLMain_CancelLock (Message, IsEmail);
This may look like this:
program OnBeforeSendingMessage;
{$I CancelLock_include.ds}
function OnBeforeSendingMessage(var Message: TStringlist; Servername: string; IsEmail: boolean):boolean;
begin
result:=true;
CLMain_CancelLock (Message, IsEmail);
//possibly some other calls to scripts
end;
begin
end.
Just compile this OnBeforeSending-Script now to get your include-file to work. The setup of the script is shown inside the script. Please take a look at this to customize the script to your own fits. Please note that whenever you reconfigure the CancelLock custom script, you have to recompile the OnBeforeSending-Script to apply the changes.
Setup in the script:
- Fill field CLSecret with your own password. Script wont work until then.
- When error occurs, script adds header field "X-CL-Error:" with some informations. They are useful mostly for me, so feel free to mail me in that case.
To define you're own password to edit the line below inside the include-file (custom script).
CLSecret := '';
type
CancelLock_hashsum = array[1..20] of byte;
procedure Init_CLMain_CancelLock (var CLSecret : String );
begin
// ----------------------------------------------------
// Configuration settings
// ----------------------------------------------------
// Implementation of Cancel-Lock
// version: 0.3, author: Jacek_FH <satan<at>hell.net.pl>}
CLSecret := ''; //must be filled with some password
// ----------------------------------------------------
// End of configuration settings
// ----------------------------------------------------
end;
// --------------------------------------------------------------- //
// ---- No user maintainable parts below this line -------------- //
// --------------------------------------------------------------- //
function CLalfab64(num: byte):char;
begin
if num < 26 then
result := chr(num+ord('A'))
else if num < 52 then
result := chr(num+ord('a')-26)
else if num < 62 then
result := chr(num+ord('0')-52)
else if num = 62 then
result := '+'
else result := '/';
end;
function CLb64enc(var buf: CancelLock_hashsum): string;
var
wynik: string;
i: byte;
begin
wynik := '123456789012345678901234567=';
for i := 0 to 5 do
begin
wynik[4*i+1]:=CLalfab64(buf[3*i+1] div 4);
wynik[4*i+2]:=CLalfab64((buf[3*i+1] mod 4)*16 + buf[3*i+2] div 16);
wynik[4*i+3]:=CLalfab64((buf[3*i+2] mod 16)*4 + buf[3*i+3] div 64);
wynik[4*i+4]:=CLalfab64(buf[3*i+3] mod 64);
end;
wynik[25]:=CLalfab64(buf[19] div 4);
wynik[26]:=CLalfab64((buf[19] mod 4)*16 + buf[20] div 16);
wynik[27]:=CLalfab64((buf[20] mod 16)*4);
result := wynik;
end;
function GetLastError(): Integer;
external 'GetLastError@kernel32.dll stdcall';
procedure Blad(var Message: TStringList; nazwa: string);
var
i,nrbledu: Integer;
begin
nrbledu := GetLastError;
for i:=0 to Message.count-1 do
if Message.strings[i] = '' then
begin
Message.Insert(i,'X-CL-Error: '+nazwa+' '+IntToStr(nrbledu));
break;
end;
end;
function CryptAcquireContext (var hProv: LongWord; pszContainer,pszProvider: PChar;
dwProvType,dwFlags: LongWord): Boolean;
external 'CryptAcquireContextA@advapi32.dll stdcall';
function CryptCreateHash (hProv: LongWord;Algid: Integer;hKey: LongWord;
dwFlags: LongWord;var hHash: LongWord): Boolean;
external 'CryptCreateHash@advapi32.dll stdcall';
function CryptHashData(hHash: LongWord; pbData: PChar;
dwDataLen: LongWord; dwFlags: LongWord): Boolean;
external 'CryptHashData@advapi32.dll stdcall';
function CryptGetHashParam (hHash: LongWord;dwParam: LongWord;var pbData: CancelLock_hashsum;
var pdwDataLen: LongWord;dwFlags: LongWord): Boolean;
external 'CryptGetHashParam@advapi32.dll stdcall';
function CryptDestroyHash (hHash: LongWord): Boolean;
external 'CryptDestroyHash@advapi32.dll stdcall';
function CryptReleaseContext (hProv: LongWord;dwFlags: LongWord): Boolean;
external 'CryptReleaseContext@advapi32.dll stdcall';
function CLsha1 (var Message: TStringList; tekst: string; var hash: CancelLock_hashsum): Boolean;
var
pProv,pHash: LongWord;
dlugosc: LongWord;
begin
result := false;
if not CryptAcquireContext(pProv, '', '', 1, 0) then
if not CryptAcquireContext(pProv, '', '', 1, 8) then
begin
Blad(Message,'CryptAcquireContext');
exit;
end;
if not CryptCreateHash(pProv,32772,0,0,pHash) then
Blad(Message,'CryptCreateHash')
else
begin
dlugosc := strlen(tekst);
if not CryptHashData(pHash,tekst,dlugosc,0) then
Blad(Message,'CryptHashData')
else
begin
dlugosc := 20;
if not CryptGetHashParam(pHash,2,hash,dlugosc,0) then
Blad(Message,'CryptGetHashParam')
else
if dlugosc = 20 then
result := true
else
Blad(Message,'BadHashLength'+' '+IntToStr(dlugosc));
end;
if pHash = 0 then
Blad(Message,'HashIsZero')
else
if not CryptDestroyHash(pHash) then
Blad(Message,'CryptDestroyHash');
end;
if pProv = 0 then
Blad(Message,'ProviderIsZero')
else
if not CryptReleaseContext(pProv, 0) then
Blad(Message,'CryptReleaseContext');
end;
procedure CLAdd(var Message: TStringList; i: Integer; Secret : String; lock: Boolean);
var
j: integer;
mid,pom: string;
hash: CancelLock_hashsum;
sum: string;
begin
j := pos('<',Message.strings[i]);
pom := copy(Message.strings[i],j+1,pos('>',Message.strings[i])-j-1);
mid:=StringOfChar(' ',Length(pom)+Length(Secret));
StrCopy(mid,pom);
StrCat(mid,Secret);
if not CLSHA1(Message,mid,hash) then
exit;
sum:=CLb64enc(hash);
if lock then
begin
mid := sum;
if not CLSHA1(Message,mid,hash) then
exit;
sum:=CLb64enc(hash);
end;
for j:=0 to Message.count-1 do
if Message.strings[j] = '' then
begin
if lock then
Message.Insert(j,'Cancel-Lock: sha1:'+sum)
else
Message.Insert(j,'Cancel-Key: sha1:'+sum);
break;
end;
end;
procedure CLMain_CancelLock (var Message : TStringlist; IsEmail : Boolean);
var
i : integer;
CLSecret : String;
begin
If not IsEmail then begin
Init_CLMain_CancelLock ( CLSecret );
if Length(CLSecret) = 0 then
begin
Blad(Message,'EmptyPassword');
exit;
end;
for i:=0 to Message.count-1 do
if pos('Subject: [Cancel control message]', Message.strings[i]) = 1 then
break;
if i < Message.count-1 then
begin
CLAdd(Message,i,CLSecret,false);
exit;
end;
for i:=0 to Message.count-1 do
if pos('Message-ID:', Message.strings[i]) = 1 then
break;
if i < Message.count-1 then
CLAdd(Message,i,CLSecret,true);
for i:=0 to Message.count-1 do
if pos('Supersedes:', Message.strings[i]) = 1 then
break;
if i < Message.count-1 then
CLAdd(Message,i,CLSecret,false);
end; // if not IsEmail
end;
René Fischer