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:

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