cgit.sxemacs.org Git - gnus/blob - lisp/ntlm.el

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