Chip 1999 January/Chip_1999-01_cd.bin/zkuste/delphi/QDB/QDB.ZIP/qdbu.pas

Pascal/Delphi Source File | 1998-06-27 | 8KB | 275 lines

{*****************************************************************************}
{                                                                             }
{          QDBU supplies the password and secure hashing for QDB              }
{            QDB v2.10 Visual Components for Delphi 1, 2, & 3                 }
{                                                                             }
{       Copyright (c) 1995, 1996, 1997, 1998 Robert R. Marsh, S.J.            }
{             & the British Province of the Society of Jesus                  }
{                                                                             }
{              This source code may *not* be redistributed                    }
{              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~                    }
{                                                                             }
{       If you like QDB and find yourself using it please consider            }
{       making a donation to your favorite charity. I would also be           }
{       pleased if you would acknowledge QDB in any projects that             }
{       make use of it.                                                       }
{                                                                             }
{       QDB is supplied as is. The author disclaims all warranties,           }
{       expressed or implied, including, without limitation, the              }
{       warranties of merchantability and of fitness for any purpose.         }
{       The author assumes no liability for damages, direct or                }
{       consequential, which may result from the use of QDB.                  }
{                                                                             }
{                           [e-mail]                                   }
{                  http://home.sprynet.com/sprynet/rrm                        }
{                                                                             }
{*****************************************************************************}

(*
  This code is based on the work of Koos Lodewijkx ([e-mail]).
*)


{$R-,A-,Q-}
unit QDBU;

interface

type
  THash = array[0..19] of Char;

function Hash(const s: string): THash;

procedure Shroud(var buffer; buflen: longint; Hash: THash);

procedure UnShroud(var buffer; buflen: longint; Hash: THash);

implementation

type
  TSHAContext = record
    State: array[0..4] of LongInt;
    Count: array[0..1] of LongInt;
    case Integer of
      0: (BufChar: array[0..63] of Byte);
      1: (BufLong: array[0..15] of LongInt)
  end;

procedure ReverseBytes(var Buf; ByteCnt: Word);
var
  BufLong: array[0..0] of LongInt absolute Buf;
  Tmp: LongInt;
  i: Word;
begin
  ByteCnt := ByteCnt div 4;
  for i := 0 to ByteCnt - 1 do begin
    Tmp := (BufLong[i] shl 16) or (BufLong[i] shr 16);
    BufLong[i] := ((Tmp and $00FF00FF) shl 8) or ((Tmp and $FF00FF00) shr 8)
  end
end;

procedure SHAInit(var SHAContext: TSHAContext);
{  Start SHA accumulation.  Set bit count to 0 and State to mysterious  }
{  initialization constants.                                            }
begin
  FillChar(SHAContext, SizeOf(TSHAContext), #0);
  with SHAContext do begin
    State[0] := $67452301;
    State[1] := $EFCDAB89;
    State[2] := $98BADCFE;
    State[3] := $10325476;
    State[4] := $C3D2E1F0
  end
end;

procedure SHATransform(var Buf: array of LongInt; const Data: array of LongInt); forward;

procedure SHAUpdate(var SHAContext: TSHAContext; const Data; Len: Word);
{  Update context to reflect the concatenation of another buffer full  }
{  of bytes.                                                           }
type
  TByteArray = array[0..0] of Byte;
var
  Index: Word;
  t: LongInt;
begin
  { Update bitcount }
  with SHAContext do begin
    t := Count[0];
    Inc(Count[0], LongInt(Len) shl 3);
    if Count[0] < t then
      Inc(Count[1]);
    Inc(Count[1], Len shr 29); { Makes no sense for Len of type Word, will be 0 }
    t := (t shr 3) and $3F;

    Index := 0;
    { Handle any leading odd-sized chunks }
    if t <> 0 then begin
      Index := t;
      t := 64 - t;
      if Len < t then begin
        Move(Data, BufChar[Index], Len);
        Exit
      end;
      Move(Data, BufChar[Index], t);
      SHATransform(State, BufLong);
      Dec(Len, t)
    end;

    { Process data in 64-byte chunks }
    while Len >= 64 do begin
      Move(TByteArray(Data)[Index], BufChar, 64);
      SHATransform(State, BufLong);
      Inc(Index, 64);
      Dec(Len, 64)
    end;

    { Handle any remaining bytes of data. }
    Move(TByteArray(Data)[Index], BufChar, Len)
  end
end;

function SHAFinal(var SHAContext: TSHAContext): THash;
var
  Cnt: Word;
  p: Byte;
  tmpres: THash;
begin
  with SHAContext do begin
    { Compute number of bytes mod 64 }
    Cnt := (Count[0] shr 3) and $3F;

    { Set the first char of padding to $80 }
    p := Cnt;
    BufChar[p] := $80;
    Inc(p);

    { Bytes of padding needed to make 64 bytes }
    Cnt := 64 - 1 - Cnt;

    { Pad out to 56 mod 64 }
    if Cnt < 8 then begin
      { Two lots of padding:  Pad the first block to 64 bytes }
      FillChar(BufChar[p], Cnt, #0);
      SHATransform(State, BufLong);

      { Now fill the next block with 56 bytes }
      FillChar(BufChar, 56, #0)
    end else
      { Pad block to 56 bytes }
      FillChar(BufChar[p], Cnt - 8, #0);

    { Append length in bits and transform }
    BufLong[14] := Count[1];
    BufLong[15] := Count[0];
    ReverseBytes(BufLong[14], 8);
    SHATransform(State, BufLong);

    { Resulting Hash equals current State }
    Move(State, tmpres, SizeOf(THash));
    ReverseBytes(tmpres, SizeOf(THash));
    Result := tmpres;
  end;

  FillChar(SHAContext, SizeOf(TSHAContext), #0)
end;

function rol(x: LongInt; cnt: Byte): LongInt;
{ Rotate left }
begin
  Result := (x shl cnt) or (x shr (32 - cnt))
end;

procedure SHATransform(var Buf: array of LongInt; const Data: array of LongInt);
var
  a, b, c, d, e: LongInt;
  Tmp: LongInt;
  w: array[0..15] of LongInt;
  i: Word;
begin
  a := Buf[0];
  b := Buf[1];
  c := Buf[2];
  d := Buf[3];
  e := Buf[4];

  Move(Data, w, 64);
  ReverseBytes(w, 64);

  for i := 0 to 79 do begin
    if i > 15 then
      w[i and 15] := rol(w[i and 15] xor w[(i - 14) and 15] xor
        w[(i - 8) and 15] xor w[(i - 3) and 15], 1);
    if i <= 19 then
      Tmp := rol(a, 5) + e + w[i and 15] + $5A827999 + ((b and c) or ((not b) and d))
    else if i <= 39 then
      Tmp := rol(a, 5) + e + w[i and 15] + $6ED9EBA1 + (b xor c xor d)
    else if i <= 59 then
      Tmp := rol(a, 5) + e + w[i and 15] + $8F1BBCDC + ((b and c) or (b and d) or (c and d))
    else
      Tmp := rol(a, 5) + e + w[i and 15] + $CA62C1D6 + (b xor c xor d);
    e := d;
    d := c;
    c := rol(b, 30);
    b := a;
    a := Tmp
  end;

  Inc(Buf[0], a);
  Inc(Buf[1], b);
  Inc(Buf[2], c);
  Inc(Buf[3], d);
  Inc(Buf[4], e)
end;

function Hash(const s: string): THash;
var
  SHAContext: TSHAContext;
begin
  SHAInit(SHAContext);
  SHAUpdate(SHAContext, s[1], length(s));
  Result := SHAFinal(SHAContext);
end;

procedure Crypt(var buffer; buflen: longint; Hash: THash);
const
  a = 1664525;
  b = 1013904223;
var
  n: longint;
  r: longint;
  ByteBuff: array[0..0] of byte absolute buffer;
  LongBuff: array[0..0] of longint absolute buffer;
  LongHash: array[0..0] of longint absolute Hash;
begin
  r := LongHash[0];
  for n := 1 to 4 do
  begin
    r := r xor LongHash[n];
  end;
  for n := 1 to (buflen div SizeOf(longint)) do
  begin
    r := a * r + b;
    LongBuff[n - 1] := LongBuff[n - 1] xor r;
  end;
  for n := SizeOf(longint) * (buflen div SizeOf(longint)) + 1 to buflen do
  begin
    r := a * r + b;
    ByteBuff[n - 1] := ByteBuff[n - 1] xor r;
  end;
end;

procedure Shroud(var buffer; buflen: longint; Hash: THash);
begin
  Crypt(buffer, buflen, Hash);
end;

procedure UnShroud(var buffer; buflen: longint; Hash: THash);
begin
  Crypt(buffer, buflen, Hash);
end;

end.