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!

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>