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

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