CancelLock
From 40tude Dialog Wiki
This little OnBeforeSending-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.
Important!
- 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.
I don't know any public server supporting Cancel-Lock. If someone know - mail me, please.
program OnBeforeSendingMessage;
{ Implementation of Cancel-Lock
version: 0.3, author: Jacek_FH <satan<at>hell.net.pl>}
const
CLSecret = ''; //must be filled with some password
type
hashsum = array[1..20] of byte;
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: 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: 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: 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; lock: Boolean);
var
j: integer;
mid,pom: string;
hash: 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(CLSecret));
StrCopy(mid,pom);
StrCat(mid,CLSecret);
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 (var Message : TStringlist);
var
i: integer;
begin
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,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,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,false);
end;
function OnBeforeSendingMessage(var Message: TStringlist; Servername: string;
IsEmail: boolean):boolean;
begin
result:=true;
if not IsEmail then
begin
CLMain (Message);
end;
end;
begin
end.
Jacek_FH <satan<at>hell.net.pl>