(*
  Translation of the SAMBA md4 code for FreePascal
  Copyright (C) 2006 by Ivo Steinmann
  Ported from SAMBA/source/libsmb/smbdes.c

  Unix SMB/CIFS implementation.

  a partial implementation of DES designed for use in the 
  SMB authentication protocol

  Copyright (C) Andrew Tridgell 1998

  This program is free software; you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation; either version 2 of the License, or
  (at your option) any later version.

  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with this program; if not, write to the Free Software
  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*)

unit ntlm;

{$mode objfpc}

interface

uses
  Strings,
  Math,
  md4;

type
  THash = array[0..15] of Byte;

procedure nt_lm_owf_gen(const pwd: PChar; var nt_p16: THash; var lm_p16: THash);
procedure hash_to_str(const h: THash; const str: PChar);

implementation


//
// Ported from SAMBA/source/libsmb/smbdes.c
//

const
  perm1: array[0..55] of Byte = (
    57, 49, 41, 33, 25, 17,  9,
     1, 58, 50, 42, 34, 26, 18,
    10,  2, 59, 51, 43, 35, 27,
    19, 11,  3, 60, 52, 44, 36,
    63, 55, 47, 39, 31, 23, 15,
     7, 62, 54, 46, 38, 30, 22,
    14,  6, 61, 53, 45, 37, 29,
    21, 13,  5, 28, 20, 12,  4);

  perm2: array[0..47] of Byte = (
    14, 17, 11, 24,  1,  5,
     3, 28, 15,  6, 21, 10,
    23, 19, 12,  4, 26,  8,
    16,  7, 27, 20, 13,  2,
    41, 52, 31, 37, 47, 55,
    30, 40, 51, 45, 33, 48,
    44, 49, 39, 56, 34, 53,
    46, 42, 50, 36, 29, 32);

  perm3: array[0..63] of Byte = (
    58, 50, 42, 34, 26, 18, 10,  2,
    60, 52, 44, 36, 28, 20, 12,  4,
    62, 54, 46, 38, 30, 22, 14,  6,
    64, 56, 48, 40, 32, 24, 16,  8,
    57, 49, 41, 33, 25, 17,  9,  1,
    59, 51, 43, 35, 27, 19, 11,  3,
    61, 53, 45, 37, 29, 21, 13,  5,
    63, 55, 47, 39, 31, 23, 15,  7);

  perm4: array[0..47] of Byte = (
    32,  1,  2,  3,  4,  5,
     4,  5,  6,  7,  8,  9,
     8,  9, 10, 11, 12, 13,
    12, 13, 14, 15, 16, 17,
    16, 17, 18, 19, 20, 21,
    20, 21, 22, 23, 24, 25,
    24, 25, 26, 27, 28, 29,
    28, 29, 30, 31, 32,  1);

  perm5: array[0..31] of Byte = (
    16,  7, 20, 21,
    29, 12, 28, 17,
     1, 15, 23, 26,
     5, 18, 31, 10,
     2,  8, 24, 14,
    32, 27,  3,  9,
    19, 13, 30,  6,
    22, 11,  4, 25);

  perm6: array[0..63] of Byte = (
    40,  8, 48, 16, 56, 24, 64, 32,
    39,  7, 47, 15, 55, 23, 63, 31,
    38,  6, 46, 14, 54, 22, 62, 30,
    37,  5, 45, 13, 53, 21, 61, 29,
    36,  4, 44, 12, 52, 20, 60, 28,
    35,  3, 43, 11, 51, 19, 59, 27,
    34,  2, 42, 10, 50, 18, 58, 26,
    33,  1, 41,  9, 49, 17, 57, 25);

  sc: array[0..15] of Byte = (1, 1, 2, 2, 2, 2, 2, 2, 1, 2, 2, 2, 2, 2, 2, 1);

  sbox: array[0..7, 0..3, 0..15] of Byte = (
    ((14,  4, 13,  1,  2, 15, 11,  8,  3, 10,  6, 12,  5,  9,  0,  7),
     (0,  15,  7,  4, 14,  2, 13,  1, 10,  6, 12, 11,  9,  5,  3,  8),
     (4,   1, 14,  8, 13,  6,  2, 11, 15, 12,  9,  7,  3, 10,  5,  0),
     (15, 12,  8,  2,  4,  9,  1,  7,  5, 11,  3, 14, 10,  0,  6, 13)),

    ((15,  1,  8, 14,  6, 11,  3,  4,  9,  7,  2, 13, 12,  0,  5, 10),
     (3,  13,  4,  7, 15,  2,  8, 14, 12,  0,  1, 10,  6,  9, 11,  5),
     (0,  14,  7, 11, 10,  4, 13,  1,  5,  8, 12,  6,  9,  3,  2, 15),
     (13,  8, 10,  1,  3, 15,  4,  2, 11,  6,  7, 12,  0,  5, 14,  9)),

    ((10,  0,  9, 14,  6,  3, 15,  5,  1, 13, 12,  7, 11,  4,  2,  8),
     (13,  7,  0,  9,  3,  4,  6, 10,  2,  8,  5, 14, 12, 11, 15,  1),
     (13,  6,  4,  9,  8, 15,  3,  0, 11,  1,  2, 12,  5, 10, 14,  7),
     (1,  10, 13,  0,  6,  9,  8,  7,  4, 15, 14,  3, 11,  5,  2, 12)),

    ((7,  13, 14,  3,  0,  6,  9, 10,  1,  2,  8,  5, 11, 12,  4, 15),
     (13,  8, 11,  5,  6, 15,  0,  3,  4,  7,  2, 12,  1, 10, 14,  9),
     (10,  6,  9,  0, 12, 11,  7, 13, 15,  1,  3, 14,  5,  2,  8,  4),
     (3,  15,  0,  6, 10,  1, 13,  8,  9,  4,  5, 11, 12,  7,  2, 14)),

    ((2,  12,  4,  1,  7, 10, 11,  6,  8,  5,  3, 15, 13,  0, 14,  9),
     (14, 11,  2, 12,  4,  7, 13,  1,  5,  0, 15, 10,  3,  9,  8,  6),
     (4,   2,  1, 11, 10, 13,  7,  8, 15,  9, 12,  5,  6,  3,  0, 14),
     (11,  8, 12,  7,  1, 14,  2, 13,  6, 15,  0,  9, 10,  4,  5,  3)),

    ((12,  1, 10, 15,  9,  2,  6,  8,  0, 13,  3,  4, 14,  7,  5, 11),
     (10, 15,  4,  2,  7, 12,  9,  5,  6,  1, 13, 14,  0, 11,  3,  8),
     (9,  14, 15,  5,  2,  8, 12,  3,  7,  0,  4, 10,  1, 13, 11,  6),
     (4,   3,  2, 12,  9,  5, 15, 10, 11, 14,  1,  7,  6,  0,  8, 13)),

    ((4, 11,  2, 14, 15,  0,  8, 13,  3, 12,  9,  7,  5, 10,  6,  1),
     (13, 0, 11,  7,  4,  9,  1, 10, 14,  3,  5, 12,  2, 15,  8,  6),
     (1,  4, 11, 13, 12,  3,  7, 14, 10, 15,  6,  8,  0,  5,  9,  2),
     (6, 11, 13,  8,  1,  4, 10,  7,  9,  5,  0, 15, 14,  2,  3, 12)),

    ((13, 2,  8,  4,  6, 15, 11,  1, 10,  9,  3, 14,  5,  0, 12,  7),
     (1, 15, 13,  8, 10,  3,  7,  4, 12,  5,  6, 11,  0, 14,  9,  2),
     (7, 11,  4,  1,  9, 12, 14,  2,  0,  6, 10, 13, 15,  3,  5,  8),
     (2,  1, 14,  7,  4, 10,  8, 13, 15, 12,  9,  0,  3,  5,  6, 11)));


procedure permute({out} const _out: PByte; {in} const _in: PByte; {in} const p: PByte; {in} const n: Integer);
var
  i: Integer;
begin
  for i := 0 to n-1 do
    _out[i] := _in[p[i]-1];
end;

procedure lshift({in/out} const d: PByte; {in} const count: Integer; {in} const n: Integer);
var
  _out  : array[0..63] of Byte;
  i     : Integer;
begin
  for i := 0 to n-1 do
    _out[i] := d[(i+count) mod n];
  for i := 0 to n-1 do
    d[i] := _out[i];
end;

procedure concat({out} const _out: PByte; {in} const _in1, _in2: PByte; {in} const l1, l2: Integer);
var
  i: Integer;
begin
  for i := 0 to l1-1 do
    _out[i] := _in1[i];
  for i := 0 to l2-1 do
    _out[i+l1] := _in2[i];
end;

procedure mxor({out} const _out: PByte; {in} const _in1, _in2: PByte; {in} const n: Integer);
var
  i: Integer;
begin
  for i := 0 to n-1 do
    _out[i] := _in1[i] xor _in2[i];
end;

procedure dohash({out} const _out: PByte; {in} const _in: PByte; {in} const key: PByte; {in} const forw: Boolean);
var
  i     : Integer;
  j     : Integer;
  k     : Integer;
  pk1   : array[0..55] of Byte;
  c     : array[0..27] of Byte;
  d     : array[0..27] of Byte;
  cd    : array[0..55] of Byte;
  ki    : array[0..15,0..47] of Byte;
  pd1   : array[0..63] of Byte;
  l     : array[0..31] of Byte;
  r     : array[0..31] of Byte;
  rl    : array[0..63] of Byte;

  er    : array[0..47] of Byte;
  erk   : array[0..47] of Byte;
  b     : array[0..7,0..5] of Byte;
  cb    : array[0..31] of Byte;
  pcb   : array[0..31] of Byte;
  r2    : array[0..31] of Byte;

  m     : Integer;
  n     : Integer;
begin
  permute(@pk1, key, @perm1, 56);

  for i := 0 to 27 do
  begin
    c[i] := pk1[i];
    d[i] := pk1[i+28];
  end;

  for i := 0 to 15 do
  begin
    lshift(@c, sc[i], 28);
    lshift(@d, sc[i], 28);

    concat(@cd, @c, @d, 28, 28);
    permute(@ki[i][0], @cd, @perm2, 48);
  end;

  permute(@pd1, _in, @perm3, 64);

  for i := 0 to 31 do
  begin
    l[i] := pd1[i];
    r[i] := pd1[i+32];
  end;

  for i := 0 to 15 do
  begin
    permute(@er, @r, @perm4, 48);

    if forw then
      mxor(@erk, @er, @ki[i][0], 48) else
      mxor(@erk, @er, @ki[15-i][0], 48);

    for j := 0 to 7 do
      for k := 0 to 5 do
        b[j][k] := erk[j*6 + k];

    for j := 0 to 7 do
    begin
      m := (b[j][0] shl 1) or b[j][5];

      n := (b[j][1] shl 3) or (b[j][2] shl 2) or (b[j][3] shl 1) or (b[j][4]);

      for k := 0 to 3 do
        b[j][k] := min(sbox[j][m][n] and (1 shl (3-k)), 1);  // store binary
    end;

    for j := 0 to 7 do
      for k := 0 to 3 do
        cb[j*4+k] := b[j][k];

    permute(@pcb, @cb, @perm5, 32);

    mxor(@r2, @l, @pcb, 32);

    for j := 0 to 31 do
    begin
      l[j] := r[j];
      r[j] := r2[j];
    end;
  end;

  concat(@rl, @r, @l, 32, 32);

  permute(_out, @rl, @perm6, 64);
end;

procedure str_to_key({in} const str: PByte; {out} const key: PByte);
var
  i: Integer;
begin
  key[0] := str[0] shr 1;
  key[1] := ((str[0] and $01) shl 6) or (str[1] shr 2);
  key[2] := ((str[1] and $03) shl 5) or (str[2] shr 3);
  key[3] := ((str[2] and $07) shl 4) or (str[3] shr 4);
  key[4] := ((str[3] and $0F) shl 3) or (str[4] shr 5);
  key[5] := ((str[4] and $1F) shl 2) or (str[5] shr 6);
  key[6] := ((str[5] and $3F) shl 1) or (str[6] shr 7);
  key[7] := str[6] and $7F;
  for i := 0 to 7 do
    key[i] := key[i] shl 1;
end;

procedure smbhash({out} const _out: PByte; {in} const _in: PByte; {in} const key: PByte; {in} const forw: Boolean);
var
  i     : Integer;
  outb  : array[0..63] of Byte;
  inb   : array[0..63] of Byte;
  keyb  : array[0..63] of Byte;
  key2  : array[0..7] of Byte;
begin
  str_to_key(key, @key2);

  for i := 0 to 63 do
  begin
    inb[i]  := min( _in[i div 8] and (1 shl (7-(i mod 8))), 1); // store binary
    keyb[i] := min(key2[i div 8] and (1 shl (7-(i mod 8))), 1); // store binary
    outb[i] := 0;
  end;

  dohash(@outb, @inb, @keyb, forw);

  for i := 0 to 7 do
    _out[I] := 0;

  for i := 0 to 63 do
  begin
    if outb[i] <> 0 then
      _out[i div 8] := _out[i div 8] or (1 shl (7-(i mod 8)));
  end;
end;

procedure E_P16({in} const p14: PByte; {out} const p16: PByte);
const
  sp8: array[0..7] of Byte = ($4b, $47, $53, $21, $40, $23, $24, $25);
begin
  smbhash(@p16[0], @sp8, @p14[0], True);
  smbhash(@p16[8], @sp8, @p14[7], True);
end;

procedure E_P24({in} const p21: PByte; {in} const c8: PByte; {out} const p24: PByte);
begin
  smbhash(@p24[0],  c8, @p21[0],  True);
  smbhash(@p24[8],  c8, @p21[7],  True);
  smbhash(@p24[16], c8, @p21[14], True);
end;



//
// Ported from SAMBA/source/libsmb/smbencrypt.c
//

(*
 * Creates the MD4 Hash of the users password in NT UNICODE.
 *)

procedure E_md4hash({in} const pwd: PByte; {out} const p16: PByte);
var
  len   : Integer;
  wpwd  : array[0..128] of Word;
begin
  FillChar(wpwd, Sizeof(wpwd), 0);

  (* Password must be converted to NT unicode - null terminated *)
  len := 0;
  while (len < 128) and (pwd[len] <> 0) do
  begin
    wpwd[len] := pwd[len];
    Inc(len);
  end;

  mdfour(p16, @wpwd[0], 2*len);

  FillChar(wpwd, Sizeof(wpwd), 0);
end;

procedure E_deshash({in} const pwd: PByte; {out} const p16: PByte);
var
  dospwd: array[0..14] of Byte;
begin
  FillChar(dospwd, Sizeof(dospwd), 0);

  (* Password must be converted to DOS charset - null terminated, uppercase *)
  StrLCopy(@dospwd, @pwd[0], Sizeof(dospwd)-1);
  StrUpper(@dospwd);

  (* ONly the first 14 chars are considered, password need not be null terminated *)
  E_P16(@dospwd, p16);

  FillChar(dospwd, Sizeof(dospwd), 0);
end;


(*
 * Does both the NT and LM owfs of a user's password
 *)

procedure nt_lm_owf_gen({in} const pwd: PChar; {out} var nt_p16: THash; {out} var lm_p16: THash);
var
  passwd: array[0..513] of Char;
begin
  FillChar(passwd, Sizeof(passwd), 0);
  StrLCopy(passwd, pwd, sizeof(passwd)-1);

  (* Calculate the MD4 hash (NT compatible) of the password *)
  FillChar(nt_p16, Sizeof(nt_p16), 0);
  E_md4hash(@passwd, @nt_p16);

  (* Calculate the SMB (lanman) hash functions of the password *)
  FillChar(lm_p16, Sizeof(lm_p16), 0);
  E_deshash(@passwd, @lm_p16);

  (* clear out local copy of user's password (just being paranoid). *)
  FillChar(passwd, Sizeof(passwd), 0);
end;

procedure hash_to_str({in} const h: THash; {out} const str: PChar);
const
  to_hex: array[0..15] of char = ('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F');
var
  i: integer;
  p: PChar;
begin
  p := str;
  for i := 0 to 15 do
  begin
     p^ := to_hex[(h[i] shr 4) and $F];
     Inc(p);
     p^ := to_hex[h[i] and $F];
     inc(p);
  end;
  p^ := #0;
end;

end.
