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