ntlm.el

   1 ;;; ntlm.el --- NTLM (NT LanManager) authentication support
   2
   3 ;; Copyright (C) 2001 Taro Kawagishi
   4 ;; Author: Taro Kawagishi <tarok@transpulse.org>
   5 ;; Keywords: NTLM, SASL
   6 ;; Version: 1.00
   7 ;; Created: February 2001
   8
   9 ;; This program is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13 ;;
  14 ;; This program is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18 ;;
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with this program; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25
  26 ;; This library is a direct translation of the Samba release 2.2.0
  27 ;; implementation of Windows NT and LanManager compatible password
  28 ;; encryption.
  29 ;;
  30 ;; Interface functions:
  31 ;;
  32 ;; ntlm-build-auth-request
  33 ;;   This will return a binary string, which should be used in the
  34 ;;   base64 encoded form and it is the caller's responsibility to encode
  35 ;;   the returned string with base64.
  36 ;;
  37 ;; ntlm-build-auth-response
  38 ;;   It is the caller's responsibility to pass a base64 decoded string
  39 ;;   (which will be a binary string) as the first argument and to
  40 ;;   encode the returned string with base64.  The second argument user
  41 ;;   should be given in user@domain format.
  42 ;;
  43 ;; ntlm-get-password-hashes
  44 ;;
  45 ;;
  46 ;; NTLM authentication procedure example:
  47 ;;
  48 ;;  1. Open a network connection to the Exchange server at the IMAP port (143)
  49 ;;  2. Receive an opening message such as:
  50 ;;     "* OK Microsoft Exchange IMAP4rev1 server version 5.5.2653.7 (XXXX) ready"
  51 ;;  3. Ask for IMAP server capability by sending "NNN capability"
  52 ;;  4. Receive a capability message such as:
  53 ;;     "* CAPABILITY IMAP4 IMAP4rev1 IDLE LITERAL+ LOGIN-REFERRALS MAILBOX-REFERRALS NAMESPACE AUTH=NTLM"
  54 ;;  5. Ask for NTLM authentication by sending a string
  55 ;;     "NNN authenticate ntlm"
  56 ;;  6. Receive continuation acknowledgment "+"
  57 ;;  7. Send NTLM authentication request generated by 'ntlm-build-auth-request
  58 ;;  8. Receive NTLM challenge string following acknowledgment "+"
  59 ;;  9. Generate response to challenge by 'ntlm-build-auth-response
  60 ;;     (here two hash function values of the user password are encrypted)
  61 ;; 10. Receive authentication completion message such as
  62 ;;     "NNN OK AUTHENTICATE NTLM completed."
  63
  64 ;;; Code:
  65
  66 (require 'md4)
  67
  68 ;;;
  69 ;;; NTLM authentication interface functions
  70
  71 (defun ntlm-build-auth-request (user &optional domain)
  72   "Return the NTLM authentication request string for USER and DOMAIN.
  73 USER is a string representing a user name to be authenticated and
  74 DOMAIN is a NT domain.  USER can include a NT domain part as in
  75 user@domain where the string after @ is used as the domain if DOMAIN
  76 is not given."
  77   (interactive)
  78   (let ((request-ident (concat "NTLMSSP" (make-string 1 0)))
  79         (request-msgType (concat (make-string 1 1) (make-string 3 0)))
  80                                         ;0x01 0x00 0x00 0x00
  81         (request-flags (concat (make-string 1 7) (make-string 1 178)
  82                                (make-string 2 0)))
  83                                         ;0x07 0xb2 0x00 0x00
  84         (request-bufIndex 0)
  85         lu ld off-d off-u)
  86     (when (string-match "@" user)
  87       (unless domain
  88         (setq domain (substring user (1+ (match-beginning 0)))))
  89       (setq user (substring user 0 (match-beginning 0))))
  90     ;; set fields offsets within the request struct
  91     (setq lu (length user))
  92     (setq ld (length domain))
  93     (setq off-u 32)                     ;offset to the string 'user
  94     (setq off-d (+ 32 lu))              ;offset to the string 'domain
  95     ;; pack the request struct in a string
  96     (concat request-ident               ;8 bytes
  97             request-msgType     ;4 bytes
  98             request-flags               ;4 bytes
  99             (pack-int16 lu)     ;user field, count field
 100             (pack-int16 lu)     ;user field, max count field
 101             (pack-int32 (cons 0 off-u)) ;user field, offset field
 102             (pack-int16 ld)     ;domain field, count field
 103             (pack-int16 ld)     ;domain field, max count field
 104             (pack-int32 (cons 0 off-d)) ;domain field, offset field
 105             user                        ;bufer field
 106             domain              ;bufer field
 107             )))
 108
 109 (defun ntlm-build-auth-response (challenge user password-hashes)
 110   "Return the response string to a challenge string CHALLENGE given by
 111 the NTLM based server for the user USER and the password hash list
 112 PASSWORD-HASHES.  NTLM uses two hash values which are represented
 113 by PASSWORD-HASHES.  PASSWORD-HASHES should be a return value of
 114  (list (smb-passwd-hash password) (ntlm-md4hash password))"
 115   (let* ((rchallenge (if (functionp 'string-as-unibyte)
 116                          (string-as-unibyte challenge)
 117                        challenge))
 118          ;; get fields within challenge struct
 119          (ident (substring rchallenge 0 8))     ;ident, 8 bytes
 120          (msgType (substring rchallenge 8 12))  ;msgType, 4 bytes
 121          (uDomain (substring rchallenge 12 20)) ;uDomain, 8 bytes
 122          (flags (substring rchallenge 20 24))   ;flags, 4 bytes
 123          (challengeData (substring rchallenge 24 32)) ;challengeData, 8 bytes
 124          uDomain-len uDomain-offs
 125          ;; response struct and its fields
 126          response
 127          lmRespData                     ;lmRespData, 24 bytes
 128          ntRespData                     ;ntRespData, 24 bytes
 129          domain                         ;ascii domain string
 130          lu ld off-lm off-nt off-d off-u off-w off-s)
 131     ;; extract domain string from challenge string
 132     (setq uDomain-len (unpack-int16 (substring uDomain 0 2)))
 133     (setq uDomain-offs (unpack-int32 (substring uDomain 4 8)))
 134     (setq domain
 135           (ntlm-unicode2ascii (substring challenge
 136                                          (cdr uDomain-offs)
 137                                          (+ (cdr uDomain-offs) uDomain-len))
 138                               (/ uDomain-len 2)))
 139     ;; overwrite domain in case user is given in <user>@<domain> format
 140     (when (string-match "@" user)
 141       (setq domain (substring user (1+ (match-beginning 0))))
 142       (setq user (substring user 0 (match-beginning 0))))
 143
 144     ;; generate response data
 145     (setq lmRespData
 146           (smb-owf-encrypt (car password-hashes) challengeData))
 147     (setq ntRespData
 148           (smb-owf-encrypt (cadr password-hashes) challengeData))
 149
 150     ;; get offsets to fields to pack the response struct in a string
 151     (setq lu (length user))
 152     (setq ld (length domain))
 153     (setq off-lm 64)                    ;offset to string 'lmResponse
 154     (setq off-nt (+ 64 24))             ;offset to string 'ntResponse
 155     (setq off-d (+ 64 48))              ;offset to string 'uDomain
 156     (setq off-u (+ 64 48 (* 2 ld)))     ;offset to string 'uUser
 157     (setq off-w (+ 64 48 (* 2 (+ ld lu)))) ;offset to string 'uWks
 158     (setq off-s (+ 64 48 (* 2 (+ ld lu lu)))) ;offset to string 'sessionKey
 159     ;; pack the response struct in a string
 160     (concat "NTLMSSP\0"                 ;response ident field, 8 bytes
 161             (pack-int32 '(0 . 3))       ;response msgType field, 4 bytes
 162
 163             ;; lmResponse field, 8 bytes
 164             ;;AddBytes(response,lmResponse,lmRespData,24);
 165             (pack-int16 24)             ;len field
 166             (pack-int16 24)             ;maxlen field
 167             (pack-int32 (cons 0 off-lm)) ;field offset
 168
 169             ;; ntResponse field, 8 bytes
 170             ;;AddBytes(response,ntResponse,ntRespData,24);
 171             (pack-int16 24)             ;len field
 172             (pack-int16 24)             ;maxlen field
 173             (pack-int32 (cons 0 off-nt)) ;field offset
 174
 175             ;; uDomain field, 8 bytes
 176             ;;AddUnicodeString(response,uDomain,domain);
 177             ;;AddBytes(response, uDomain, udomain, 2*ld);
 178             (pack-int16 (* 2 ld))       ;len field
 179             (pack-int16 (* 2 ld))       ;maxlen field
 180             (pack-int32 (cons 0 off-d)) ;field offset
 181
 182             ;; uUser field, 8 bytes
 183             ;;AddUnicodeString(response,uUser,u);
 184             ;;AddBytes(response, uUser, uuser, 2*lu);
 185             (pack-int16 (* 2 lu))       ;len field
 186             (pack-int16 (* 2 lu))       ;maxlen field
 187             (pack-int32 (cons 0 off-u)) ;field offset
 188
 189             ;; uWks field, 8 bytes
 190             ;;AddUnicodeString(response,uWks,u);
 191             (pack-int16 (* 2 lu))       ;len field
 192             (pack-int16 (* 2 lu))       ;maxlen field
 193             (pack-int32 (cons 0 off-w)) ;field offset
 194
 195             ;; sessionKey field, 8 bytes
 196             ;;AddString(response,sessionKey,NULL);
 197             (pack-int16 0)              ;len field
 198             (pack-int16 0)              ;maxlen field
 199             (pack-int32 (cons 0 (- off-s off-lm))) ;field offset
 200
 201             ;; flags field, 4 bytes
 202             flags                       ;
 203
 204             ;; buffer field
 205             lmRespData                  ;lmResponse, 24 bytes
 206             ntRespData                  ;ntResponse, 24 bytes
 207             (ntlm-ascii2unicode domain  ;unicode domain string, 2*ld bytes
 208                                 (length domain)) ;
 209             (ntlm-ascii2unicode user    ;unicode user string, 2*lu bytes
 210                                 (length user)) ;
 211             (ntlm-ascii2unicode user    ;unicode user string, 2*lu bytes
 212                                 (length user)) ;
 213             )))
 214
 215 (defun ntlm-get-password-hashes (password)
 216   "Return a pair of SMB hash and NT MD4 hash of the given password PASSWORD"
 217   (list (smb-passwd-hash password)
 218         (ntlm-md4hash password)))
 219
 220 ;;;
 221 ;;; sub functions
 222
 223 (defun pack-int16 (int16)
 224   "Pack 16 bits integer in 2 bytes string as little endian."
 225   (let ((str (make-string 2 0)))
 226     (aset str 0 (logand int16 255))
 227     (aset str 1 (lsh int16 -8))
 228     str))
 229
 230 (defun pack-int32 (int32)
 231   "Pack 32 bits integer in a 4 bytes string as little endian.  A 32 bits
 232 integer is represented as a pair of two 16 bits integers (cons high low)."
 233   (let ((str (make-string 4 0))
 234         (h (car int32)) (l (cdr int32)))
 235     (aset str 0 (logand l 255))
 236     (aset str 1 (lsh l -8))
 237     (aset str 2 (logand h 255))
 238     (aset str 3 (lsh h -8))
 239     str))
 240
 241 (defun unpack-int16 (str)
 242   (if (eq 2 (length str))
 243       (+ (lsh (aref str 1) 8) (aref str 0))
 244     (error "%s is not 2 bytes long" str)))
 245
 246 (defun unpack-int32 (str)
 247   (if (eq 4 (length str))
 248       (cons (+ (lsh (aref str 3) 8) (aref str 2))
 249             (+ (lsh (aref str 1) 8) (aref str 0)))
 250     (error "%s is not 4 bytes long" str)))
 251
 252 (defun ntlm-ascii2unicode (str len)
 253   "Convert an ASCII string into a NT Unicode string, which is
 254 little-endian utf16."
 255   (let ((utf (make-string (* 2 len) 0)) (i 0) val)
 256     (while (and (< i len)
 257                 (not (zerop (setq val (aref str i)))))
 258       (aset utf (* 2 i) val)
 259       (aset utf (1+ (* 2 i)) 0)
 260       (setq i (1+ i)))
 261     utf))
 262
 263 (defun ntlm-unicode2ascii (str len)
 264   "Extract 7 bits ASCII part of a little endian utf16 string STR of length
 265 LEN."
 266   (let ((buf (make-string len 0)) (i 0) (j 0))
 267     (while (< i len)
 268       (aset buf i (logand (aref str j) 127)) ;(string-to-number "7f" 16)
 269       (setq i (1+ i)
 270             j (+ 2 j)))
 271     buf))
 272
 273 (defun smb-passwd-hash (passwd)
 274   "Return the SMB password hash string of 16 bytes long for the given password
 275 string PASSWD.  PASSWD is truncated to 14 bytes if longer."
 276   (let* ((len (min (length passwd) 14))
 277          p15)
 278     (setq p15 (concat (substring passwd 0 len) ;fill top 14 bytes with passwd
 279                       (make-string (- 15 len) 0)))
 280     (smbdes-e-p16 (upcase p15))))
 281
 282 (defun smb-owf-encrypt (passwd c8)
 283   "Return the response string of 24 bytes long for the given password
 284 string PASSWD based on the DES encryption.  PASSWD is of at most 14
 285 bytes long and the challenge string C8 of 8 bytes long."
 286   (let ((len (min (length passwd) 16)) p22)
 287     (setq p22 (concat (substring passwd 0 len) ;fill top 16 bytes with passwd
 288                       (make-string (- 22 len) 0)))
 289     (smbdes-e-p24 p22 c8)))
 290
 291 (defun smbdes-e-p24 (p22 c8)
 292   "Return a 24 bytes hashed string for a 21 bytes string P22 and a 8 bytes
 293 string C8."
 294   (concat (smbhash c8 p22 t)            ;hash first 8 bytes of p22
 295           (smbhash c8 (substring p22 7) t)
 296           (smbhash c8 (substring p22 14) t)))
 297
 298 (defconst smb-sp8 [75 71 83 33 64 35 36 37])
 299
 300 (defun smbdes-e-p16 (p15)
 301   "Return a 16 bytes hashed string for a 15 bytes string P15."
 302   (concat (smbhash smb-sp8 p15 t)       ;hash of first 8 bytes of p15
 303           (smbhash smb-sp8 (substring p15 7) t) ;hash of last 8 bytes of p15
 304           ))
 305
 306 (defun smbhash (in key forw)
 307   "Return the hash string of length 8 for a string IN of length 8 and
 308 a string KEY of length 8.  FORW is t or nil."
 309   (let ((out (make-string 8 0))
 310         outb                            ;string of length 64
 311         (inb (make-string 64 0))
 312         (keyb (make-string 64 0))
 313         (key2 (smb-str-to-key key))
 314         (i 0) aa)
 315     (while (< i 64)
 316       (unless (zerop (logand (aref in (/ i 8)) (lsh 1 (- 7 (% i 8)))))
 317         (aset inb i 1))
 318       (unless (zerop (logand (aref key2 (/ i 8)) (lsh 1 (- 7 (% i 8)))))
 319         (aset keyb i 1))
 320       (setq i (1+ i)))
 321     (setq outb (smb-dohash inb keyb forw))
 322     (setq i 0)
 323     (while (< i 64)
 324       (unless (zerop (aref outb i))
 325         (setq aa (aref out (/ i 8)))
 326         (aset out (/ i 8)
 327               (logior aa (lsh 1 (- 7 (% i 8))))))
 328       (setq i (1+ i)))
 329     out))
 330
 331 (defun smb-str-to-key (str)
 332   "Return a string of length 8 for the given string STR of length 7."
 333   (let ((key (make-string 8 0))
 334         (i 7))
 335     (aset key 0 (lsh (aref str 0) -1))
 336     (aset key 1 (logior
 337                  (lsh (logand (aref str 0) 1) 6)
 338                  (lsh (aref str 1) -2)))
 339     (aset key 2 (logior
 340                  (lsh (logand (aref str 1) 3) 5)
 341                  (lsh (aref str 2) -3)))
 342     (aset key 3 (logior
 343                  (lsh (logand (aref str 2) 7) 4)
 344                  (lsh (aref str 3) -4)))
 345     (aset key 4 (logior
 346                  (lsh (logand (aref str 3) 15) 3)
 347                  (lsh (aref str 4) -5)))
 348     (aset key 5 (logior
 349                  (lsh (logand (aref str 4) 31) 2)
 350                  (lsh (aref str 5) -6)))
 351     (aset key 6 (logior
 352                  (lsh (logand (aref str 5) 63) 1)
 353                  (lsh (aref str 6) -7)))
 354     (aset key 7 (logand (aref str 6) 127))
 355     (while (>= i 0)
 356       (aset key i (lsh (aref key i) 1))
 357       (setq i (1- i)))
 358     key))
 359
 360 (defconst smb-perm1 [57 49 41 33 25 17  9
 361                      1 58 50 42 34 26 18
 362                      10  2 59 51 43 35 27
 363                      19 11  3 60 52 44 36
 364                      63 55 47 39 31 23 15
 365                      7 62 54 46 38 30 22
 366                      14  6 61 53 45 37 29
 367                      21 13  5 28 20 12  4])
 368
 369 (defconst smb-perm2 [14 17 11 24  1  5
 370                      3 28 15  6 21 10
 371                      23 19 12  4 26  8
 372                      16  7 27 20 13  2
 373                      41 52 31 37 47 55
 374                      30 40 51 45 33 48
 375                      44 49 39 56 34 53
 376                      46 42 50 36 29 32])
 377
 378 (defconst smb-perm3 [58 50 42 34 26 18 10  2
 379                      60 52 44 36 28 20 12  4
 380                      62 54 46 38 30 22 14  6
 381                      64 56 48 40 32 24 16  8
 382                      57 49 41 33 25 17  9  1
 383                      59 51 43 35 27 19 11  3
 384                      61 53 45 37 29 21 13  5
 385                      63 55 47 39 31 23 15  7])
 386
 387 (defconst smb-perm4 [32  1  2  3  4  5
 388                      4  5  6  7  8  9
 389                      8  9 10 11 12 13
 390                      12 13 14 15 16 17
 391                      16 17 18 19 20 21
 392                      20 21 22 23 24 25
 393                      24 25 26 27 28 29
 394                      28 29 30 31 32  1])
 395
 396 (defconst smb-perm5 [16  7 20 21
 397                      29 12 28 17
 398                      1 15 23 26
 399                      5 18 31 10
 400                      2  8 24 14
 401                      32 27  3  9
 402                      19 13 30  6
 403                      22 11  4 25])
 404
 405 (defconst smb-perm6 [40  8 48 16 56 24 64 32
 406                      39  7 47 15 55 23 63 31
 407                      38  6 46 14 54 22 62 30
 408                      37  5 45 13 53 21 61 29
 409                      36  4 44 12 52 20 60 28
 410                      35  3 43 11 51 19 59 27
 411                      34  2 42 10 50 18 58 26
 412                      33  1 41  9 49 17 57 25])
 413
 414 (defconst smb-sc [1 1 2 2 2 2 2 2 1 2 2 2 2 2 2 1])
 415
 416 (defconst smb-sbox [[[14  4 13  1  2 15 11  8  3 10  6 12  5  9  0  7]
 417                      [ 0 15  7  4 14  2 13  1 10  6 12 11  9  5  3  8]
 418                      [ 4  1 14  8 13  6  2 11 15 12  9  7  3 10  5  0]
 419                      [15 12  8  2  4  9  1  7  5 11  3 14 10  0  6 13]]
 420                     [[15  1  8 14  6 11  3  4  9  7  2 13 12  0  5 10]
 421                      [ 3 13  4  7 15  2  8 14 12  0  1 10  6  9 11  5]
 422                      [ 0 14  7 11 10  4 13  1  5  8 12  6  9  3  2 15]
 423                      [13  8 10  1  3 15  4  2 11  6  7 12  0  5 14  9]]
 424                     [[10  0  9 14  6  3 15  5  1 13 12  7 11  4  2  8]
 425                      [13  7  0  9  3  4  6 10  2  8  5 14 12 11 15  1]
 426                      [13  6  4  9  8 15  3  0 11  1  2 12  5 10 14  7]
 427                      [ 1 10 13  0  6  9  8  7  4 15 14  3 11  5  2 12]]
 428                     [[ 7 13 14  3  0  6  9 10  1  2  8  5 11 12  4 15]
 429                      [13  8 11  5  6 15  0  3  4  7  2 12  1 10 14  9]
 430                      [10  6  9  0 12 11  7 13 15  1  3 14  5  2  8  4]
 431                      [ 3 15  0  6 10  1 13  8  9  4  5 11 12  7  2 14]]
 432                     [[ 2 12  4  1  7 10 11  6  8  5  3 15 13  0 14  9]
 433                      [14 11  2 12  4  7 13  1  5  0 15 10  3  9  8  6]
 434                      [ 4  2  1 11 10 13  7  8 15  9 12  5  6  3  0 14]
 435                      [11  8 12  7  1 14  2 13  6 15  0  9 10  4  5  3]]
 436                     [[12  1 10 15  9  2  6  8  0 13  3  4 14  7  5 11]
 437                      [10 15  4  2  7 12  9  5  6  1 13 14  0 11  3  8]
 438                      [ 9 14 15  5  2  8 12  3  7  0  4 10  1 13 11  6]
 439                      [ 4  3  2 12  9  5 15 10 11 14  1  7  6  0  8 13]]
 440                     [[ 4 11  2 14 15  0  8 13  3 12  9  7  5 10  6  1]
 441                      [13  0 11  7  4  9  1 10 14  3  5 12  2 15  8  6]
 442                      [ 1  4 11 13 12  3  7 14 10 15  6  8  0  5  9  2]
 443                      [ 6 11 13  8  1  4 10  7  9  5  0 15 14  2  3 12]]
 444                     [[13  2  8  4  6 15 11  1 10  9  3 14  5  0 12  7]
 445                      [ 1 15 13  8 10  3  7  4 12  5  6 11  0 14  9  2]
 446                      [ 7 11  4  1  9 12 14  2  0  6 10 13 15  3  5  8]
 447                      [ 2  1 14  7  4 10  8 13 15 12  9  0  3  5  6 11]]])
 448
 449 (defsubst string-permute (in perm n)
 450   "Return a string of length N for a string IN and a permutation vector
 451 PERM of size N.  The length of IN should be height of PERM."
 452   (let ((i 0) (out (make-string n 0)))
 453     (while (< i n)
 454       (aset out i (aref in (- (aref perm i) 1)))
 455       (setq i (1+ i)))
 456     out))
 457
 458 (defsubst string-lshift (str count len)
 459   "Return a string by circularly shifting a string STR by COUNT to the left.
 460 length of STR is LEN."
 461   (let ((c (% count len)))
 462     (concat (substring str c len) (substring str 0 c))))
 463
 464 (defsubst string-xor (in1 in2 n)
 465   "Return exclusive-or of sequences in1 and in2"
 466   (let ((w (make-string n 0)) (i 0))
 467     (while (< i n)
 468       (aset w i (logxor (aref in1 i) (aref in2 i)))
 469       (setq i (1+ i)))
 470     w))
 471
 472 (defun smb-dohash (in key forw)
 473   "Return the hash value for a string IN and a string KEY.
 474 Length of IN and KEY are 64.  FORW non nill means forward, nil means
 475 backward."
 476   (let (pk1                             ;string of length 56
 477         c                               ;string of length 28
 478         d                               ;string of length 28
 479         cd                              ;string of length 56
 480         (ki (make-vector 16 0))         ;vector of string of length 48
 481         pd1                             ;string of length 64
 482         l                               ;string of length 32
 483         r                               ;string of length 32
 484         rl                              ;string of length 64
 485         (i 0) (j 0) (k 0))
 486     (setq pk1 (string-permute key smb-perm1 56))
 487     (setq c (substring pk1 0 28))
 488     (setq d (substring pk1 28 56))
 489
 490     (setq i 0)
 491     (while (< i 16)
 492       (setq c (string-lshift c (aref smb-sc i) 28))
 493       (setq d (string-lshift d (aref smb-sc i) 28))
 494       (setq cd (concat (substring c 0 28) (substring d 0 28)))
 495       (aset ki i (string-permute cd smb-perm2 48))
 496       (setq i (1+ i)))
 497
 498     (setq pd1 (string-permute in smb-perm3 64))
 499
 500     (setq l (substring pd1 0 32))
 501     (setq r (substring pd1 32 64))
 502
 503     (setq i 0)
 504     (let (er                            ;string of length 48
 505           erk                           ;string of length 48
 506           (b (make-vector 8 0))         ;vector of strings of length 6
 507           cb                            ;string of length 32
 508           pcb                           ;string of length 32
 509           r2                            ;string of length 32
 510           jj m n bj sbox-jmn)
 511       (while (< i 16)
 512         (setq er (string-permute r smb-perm4 48))
 513         (setq erk (string-xor er
 514                        (aref ki (if forw i (- 15 i)))
 515                        48))
 516         (setq j 0)
 517         (while (< j 8)
 518           (setq jj (* 6 j))
 519           (aset b j (substring erk jj (+ jj 6)))
 520           (setq j (1+ j)))
 521         (setq j 0)
 522         (while (< j 8)
 523           (setq bj (aref b j))
 524           (setq m (logior (lsh (aref bj 0) 1) (aref bj 5)))
 525           (setq n (logior (lsh (aref bj 1) 3)
 526                           (lsh (aref bj 2) 2)
 527                           (lsh (aref bj 3) 1)
 528                           (aref bj 4)))
 529           (setq k 0)
 530           (setq sbox-jmn (aref (aref (aref smb-sbox j) m) n))
 531           (while (< k 4)
 532             (aset bj k
 533                   (if (zerop (logand sbox-jmn (lsh 1 (- 3 k))))
 534                       0 1))
 535             (setq k (1+ k)))
 536           (setq j (1+ j)))
 537
 538         (setq j 0)
 539         (setq cb nil)
 540         (while (< j 8)
 541           (setq cb (concat cb (substring (aref b j) 0 4)))
 542           (setq j (1+ j)))
 543
 544         (setq pcb (string-permute cb smb-perm5 32))
 545         (setq r2 (string-xor l pcb 32))
 546         (setq l r)
 547         (setq r r2)
 548         (setq i (1+ i))))
 549     (setq rl (concat r l))
 550     (string-permute rl smb-perm6 64)))
 551
 552 (defun ntlm-md4hash (passwd)
 553   "Return the 16 bytes MD4 hash of a string PASSWD after converting it
 554 into a Unicode string.  PASSWD is truncated to 128 bytes if longer."
 555   (let (len wpwd)
 556     ;; Password cannot be longer than 128 characters
 557     (setq len (length passwd))
 558     (if (> len 128)
 559         (setq len 128))
 560     ;; Password must be converted to NT unicode
 561     (setq wpwd (ntlm-ascii2unicode passwd len))
 562     ;; Calculate length in bytes
 563     (setq len (* len 2))
 564     (md4 wpwd len)))
 565
 566 (provide 'ntlm)
 567
 568 ;;; ntlm.el ends here