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

   1 ;;; ntlm.el --- NTLM (NT LanManager) authentication support
   2
   3 ;; Copyright (C) 2001, 2007-2016 Free Software Foundation, Inc.
   4
   5 ;; Author: Taro Kawagishi <tarok@transpulse.org>
   6 ;; Maintainer: Thomas Fitzsimmons <fitzsim@fitzsim.org>
   7 ;; Keywords: NTLM, SASL, comm
   8 ;; Version: 2.0.0
   9 ;; Created: February 2001
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software: you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation, either version 3 of the License, or
  16 ;; (at your option) any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  25
  26 ;;; Commentary:
  27
  28 ;; This library is a direct translation of the Samba release 2.2.0
  29 ;; implementation of Windows NT and LanManager compatible password
  30 ;; encryption.
  31 ;;
  32 ;; Interface functions:
  33 ;;
  34 ;; ntlm-build-auth-request
  35 ;;   This will return a binary string, which should be used in the
  36 ;;   base64 encoded form and it is the caller's responsibility to encode
  37 ;;   the returned string with base64.
  38 ;;
  39 ;; ntlm-build-auth-response
  40 ;;   It is the caller's responsibility to pass a base64 decoded string
  41 ;;   (which will be a binary string) as the first argument and to
  42 ;;   encode the returned string with base64.  The second argument user
  43 ;;   should be given in user@domain format.
  44 ;;
  45 ;; ntlm-get-password-hashes
  46 ;;
  47 ;;
  48 ;; NTLM authentication procedure example:
  49 ;;
  50 ;;  1. Open a network connection to the Exchange server at the IMAP port (143)
  51 ;;  2. Receive an opening message such as:
  52 ;;     "* OK Microsoft Exchange IMAP4rev1 server version 5.5.2653.7 (XXXX) ready"
  53 ;;  3. Ask for IMAP server capability by sending "NNN capability"
  54 ;;  4. Receive a capability message such as:
  55 ;;     "* CAPABILITY IMAP4 IMAP4rev1 IDLE LITERAL+ LOGIN-REFERRALS MAILBOX-REFERRALS NAMESPACE AUTH=NTLM"
  56 ;;  5. Ask for NTLM authentication by sending a string
  57 ;;     "NNN authenticate ntlm"
  58 ;;  6. Receive continuation acknowledgment "+"
  59 ;;  7. Send NTLM authentication request generated by 'ntlm-build-auth-request
  60 ;;  8. Receive NTLM challenge string following acknowledgment "+"
  61 ;;  9. Generate response to challenge by 'ntlm-build-auth-response
  62 ;;     (here two hash function values of the user password are encrypted)
  63 ;; 10. Receive authentication completion message such as
  64 ;;     "NNN OK AUTHENTICATE NTLM completed."
  65
  66 ;;; Code:
  67
  68 (require 'md4)
  69 (require 'hmac-md5)
  70 (require 'calc)
  71
  72 (defgroup ntlm nil
  73   "NTLM (NT LanManager) authentication."
  74   :version "25.1"
  75   :group 'comm)
  76
  77 (defcustom ntlm-compatibility-level 5
  78   "The NTLM compatibility level.
  79 Ordered from 0, the oldest, least-secure level through 5, the
  80 newest, most-secure level.  Newer servers may reject lower
  81 levels.  At levels 3 through 5, send LMv2 and NTLMv2 responses.
  82 At levels 0, 1 and 2, send LM and NTLM responses.
  83
  84 In this implementation, levels 0, 1 and 2 are the same (old,
  85 insecure), and levels 3, 4 and 5 are the same (new, secure).  If
  86 NTLM authentication isn't working at level 5, try level 0.  The
  87 other levels are only present because other clients have six
  88 levels."
  89   :type '(choice (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
  90
  91 ;;;
  92 ;;; NTLM authentication interface functions
  93
  94 (defun ntlm-build-auth-request (user &optional domain)
  95   "Return the NTLM authentication request string for USER and DOMAIN.
  96 USER is a string representing a user name to be authenticated and
  97 DOMAIN is a NT domain.  USER can include a NT domain part as in
  98 user@domain where the string after @ is used as the domain if DOMAIN
  99 is not given."
 100   (interactive)
 101   (let ((request-ident (concat "NTLMSSP" (make-string 1 0)))
 102         (request-msgType (concat (make-string 1 1) (make-string 3 0)))
 103                                         ;0x01 0x00 0x00 0x00
 104         (request-flags (concat (make-string 1 7) (make-string 1 178)
 105                                (make-string 1 8) (make-string 1 0)))
 106                                         ;0x07 0xb2 0x08 0x00
 107         lu ld off-d off-u)
 108     (when (string-match "@" user)
 109       (unless domain
 110         (setq domain (substring user (1+ (match-beginning 0)))))
 111       (setq user (substring user 0 (match-beginning 0))))
 112     ;; set fields offsets within the request struct
 113     (setq lu (length user))
 114     (setq ld (length domain))
 115     (setq off-u 32)                     ;offset to the string 'user
 116     (setq off-d (+ 32 lu))              ;offset to the string 'domain
 117     ;; pack the request struct in a string
 118     (concat request-ident               ;8 bytes
 119             request-msgType     ;4 bytes
 120             request-flags               ;4 bytes
 121             (md4-pack-int16 lu) ;user field, count field
 122             (md4-pack-int16 lu) ;user field, max count field
 123             (md4-pack-int32 (cons 0 off-u)) ;user field, offset field
 124             (md4-pack-int16 ld) ;domain field, count field
 125             (md4-pack-int16 ld) ;domain field, max count field
 126             (md4-pack-int32 (cons 0 off-d)) ;domain field, offset field
 127             user                        ;buffer field
 128             domain              ;buffer field
 129             )))
 130
 131 (eval-when-compile
 132   (defmacro ntlm-string-as-unibyte (string)
 133     (if (fboundp 'string-as-unibyte)
 134         `(string-as-unibyte ,string)
 135       string))
 136   (defmacro ntlm-string-make-unibyte (string)
 137     (if (fboundp 'string-make-unibyte)
 138         `(string-make-unibyte ,string)
 139       string))
 140   (defmacro ntlm-unibyte-string (&rest bytes)
 141     (if (fboundp 'unibyte-string)
 142         `(unibyte-string ,@bytes)
 143       `(concat (vector ,@bytes)))))
 144
 145 (eval-and-compile
 146   (autoload 'sha1 "sha1")
 147   (if (fboundp 'secure-hash)
 148       (defalias 'ntlm-secure-hash 'secure-hash)
 149     (defun ntlm-secure-hash (algorithm object &optional start end binary)
 150       "Return the secure hash of OBJECT, a buffer or string.
 151 ALGORITHM is a symbol specifying the hash to use: md5, sha1.
 152
 153 The two optional arguments START and END are positions specifying for
 154 which part of OBJECT to compute the hash.  If nil or omitted, uses the
 155 whole OBJECT.
 156
 157 If BINARY is non-nil, returns a string in binary form."
 158       (cond ((eq algorithm 'md5)
 159              (if binary
 160                  (let* ((hex (md5 object start end))
 161                         (len (length hex))
 162                         (beg 0)
 163                         rest)
 164                    (while (< beg len)
 165                      (push (ntlm-string-make-unibyte
 166                             (char-to-string
 167                              (string-to-number
 168                               (substring hex beg (setq beg (+ beg 2)))
 169                               16)))
 170                            rest))
 171                    (apply #'concat (nreverse rest)))
 172                (md5 object start end)))
 173             ((eq algorithm 'sha1)
 174              (sha1 object start end binary))
 175             (t
 176              (error "(ntlm-secure-hash) Unsupported algorithm: %s"
 177                     algorithm))))))
 178
 179 (defun ntlm-compute-timestamp ()
 180   "Compute an NTLMv2 timestamp.
 181 Return a unibyte string representing the number of tenths of a
 182 microsecond since January 1, 1601 as a 64-bit little-endian
 183 signed integer."
 184   (let* ((s-to-tenths-of-us "mul(add(lsh($1,16),$2),10000000)")
 185          (us-to-tenths-of-us "mul($3,10)")
 186          (ps-to-tenths-of-us "idiv($4,100000)")
 187          (tenths-of-us-since-jan-1-1601
 188           (apply 'calc-eval (concat "add(add(add("
 189                                     s-to-tenths-of-us ","
 190                                     us-to-tenths-of-us "),"
 191                                     ps-to-tenths-of-us "),"
 192                                     ;; tenths of microseconds between
 193                                     ;; 1601-01-01 and 1970-01-01
 194                                     "116444736000000000)")
 195                  ;; add trailing zeros to support old current-time formats
 196                  'rawnum (append (current-time) '(0 0))))
 197          result-bytes)
 198     (dotimes (byte 8)
 199       (push (calc-eval "and($1,16#FF)" 'rawnum tenths-of-us-since-jan-1-1601)
 200             result-bytes)
 201       (setq tenths-of-us-since-jan-1-1601
 202             (calc-eval "rsh($1,8,64)" 'rawnum tenths-of-us-since-jan-1-1601)))
 203     (apply 'ntlm-unibyte-string (nreverse result-bytes))))
 204
 205 (defun ntlm-generate-nonce ()
 206   "Generate a random nonce, not to be used more than once.
 207 Return a random eight byte unibyte string."
 208   (ntlm-unibyte-string
 209    (random 256) (random 256) (random 256) (random 256)
 210    (random 256) (random 256) (random 256) (random 256)))
 211
 212 (defun ntlm-build-auth-response (challenge user password-hashes)
 213   "Return the response string to a challenge string CHALLENGE given by
 214 the NTLM based server for the user USER and the password hash list
 215 PASSWORD-HASHES.  NTLM uses two hash values which are represented
 216 by PASSWORD-HASHES.  PASSWORD-HASHES should be a return value of
 217  (list (ntlm-smb-passwd-hash password) (ntlm-md4hash password))"
 218   (let* ((rchallenge (ntlm-string-as-unibyte challenge))
 219          ;; get fields within challenge struct
 220          ;;(ident (substring rchallenge 0 8))   ;ident, 8 bytes
 221          ;;(msgType (substring rchallenge 8 12))        ;msgType, 4 bytes
 222          (uDomain (substring rchallenge 12 20)) ;uDomain, 8 bytes
 223          (flags (substring rchallenge 20 24))   ;flags, 4 bytes
 224          (challengeData (substring rchallenge 24 32)) ;challengeData, 8 bytes
 225          uDomain-len uDomain-offs
 226          ;; response struct and its fields
 227          lmRespData                     ;lmRespData, 24 bytes
 228          ntRespData                     ;ntRespData, variable length
 229          domain                         ;ascii domain string
 230          lu ld ln off-lm off-nt off-d off-u off-w off-s)
 231     ;; extract domain string from challenge string
 232     (setq uDomain-len (md4-unpack-int16 (substring uDomain 0 2)))
 233     (setq uDomain-offs (md4-unpack-int32 (substring uDomain 4 8)))
 234     (setq domain
 235           (ntlm-unicode2ascii (substring challenge
 236                                          (cdr uDomain-offs)
 237                                          (+ (cdr uDomain-offs) uDomain-len))
 238                               (/ uDomain-len 2)))
 239     ;; overwrite domain in case user is given in <user>@<domain> format
 240     (when (string-match "@" user)
 241       (setq domain (substring user (1+ (match-beginning 0))))
 242       (setq user (substring user 0 (match-beginning 0))))
 243
 244     (unless (and (integerp ntlm-compatibility-level)
 245                  (>= ntlm-compatibility-level 0)
 246                  (<= ntlm-compatibility-level 5))
 247       (error "Invalid ntlm-compatibility-level value"))
 248     (if (and (>= ntlm-compatibility-level 3)
 249              (<= ntlm-compatibility-level 5))
 250         ;; extract target information block, if it is present
 251         (if (< (cdr uDomain-offs) 48)
 252             (error "Failed to find target information block")
 253           (let* ((targetInfo-len (md4-unpack-int16 (substring rchallenge
 254                                                               40 42)))
 255                  (targetInfo-offs (md4-unpack-int32 (substring rchallenge
 256                                                                44 48)))
 257                  (targetInfo (substring rchallenge
 258                                         (cdr targetInfo-offs)
 259                                         (+ (cdr targetInfo-offs)
 260                                            targetInfo-len)))
 261                  (upcase-user (upcase (ntlm-ascii2unicode user (length user))))
 262                  (ntlmv2-hash (hmac-md5 (concat upcase-user
 263                                                 (ntlm-ascii2unicode
 264                                                  domain (length domain)))
 265                                         (cadr password-hashes)))
 266                  (nonce (ntlm-generate-nonce))
 267                  (blob (concat (make-string 2 1)
 268                                (make-string 2 0)        ; blob signature
 269                                (make-string 4 0)        ; reserved value
 270                                (ntlm-compute-timestamp) ; timestamp
 271                                nonce                    ; client nonce
 272                                (make-string 4 0)        ; unknown
 273                                targetInfo               ; target info
 274                                (make-string 4 0)))      ; unknown
 275                  ;; for reference: LMv2 interim calculation
 276                  ;; (lm-interim (hmac-md5 (concat challengeData nonce)
 277                  ;;                       ntlmv2-hash))
 278                  (nt-interim (hmac-md5 (concat challengeData blob)
 279                                        ntlmv2-hash)))
 280             ;; for reference: LMv2 field, but match other clients that
 281             ;; send all zeros
 282             ;; (setq lmRespData (concat lm-interim nonce))
 283             (setq lmRespData (make-string 24 0))
 284             (setq ntRespData (concat nt-interim blob))))
 285       ;; compatibility level is 2, 1 or 0
 286       ;; level 2 should be treated specially but it's not clear how,
 287       ;; so just treat it the same as levels 0 and 1
 288       ;; check if "negotiate NTLM2 key" flag is set in type 2 message
 289       (if (not (zerop (logand (aref flags 2) 8)))
 290           (let (randomString
 291                 sessionHash)
 292             ;; generate NTLM2 session response data
 293             (setq randomString (ntlm-generate-nonce))
 294             (setq sessionHash (ntlm-secure-hash
 295                                'md5 (concat challengeData randomString)
 296                                nil nil t))
 297             (setq sessionHash (substring sessionHash 0 8))
 298             (setq lmRespData (concat randomString (make-string 16 0)))
 299             (setq ntRespData (ntlm-smb-owf-encrypt
 300                               (cadr password-hashes) sessionHash)))
 301         ;; generate response data
 302         (setq lmRespData
 303               (ntlm-smb-owf-encrypt (car password-hashes) challengeData))
 304         (setq ntRespData
 305               (ntlm-smb-owf-encrypt (cadr password-hashes) challengeData))))
 306
 307     ;; get offsets to fields to pack the response struct in a string
 308     (setq lu (length user))
 309     (setq ld (length domain))
 310     (setq ln (length ntRespData))
 311     (setq off-lm 64)                    ;offset to string 'lmResponse
 312     (setq off-nt (+ 64 24))             ;offset to string 'ntResponse
 313     (setq off-d (+ 64 24 ln))           ;offset to string 'uDomain
 314     (setq off-u (+ 64 24 ln (* 2 ld)))  ;offset to string 'uUser
 315     (setq off-w (+ 64 24 ln (* 2 (+ ld lu)))) ;offset to string 'uWks
 316     (setq off-s (+ 64 24 ln (* 2 (+ ld lu lu)))) ;offset to string 'sessionKey
 317     ;; pack the response struct in a string
 318     (concat "NTLMSSP\0"                 ;response ident field, 8 bytes
 319             (md4-pack-int32 '(0 . 3))   ;response msgType field, 4 bytes
 320
 321             ;; lmResponse field, 8 bytes
 322             ;;AddBytes(response,lmResponse,lmRespData,24);
 323             (md4-pack-int16 24)         ;len field
 324             (md4-pack-int16 24)         ;maxlen field
 325             (md4-pack-int32 (cons 0 off-lm)) ;field offset
 326
 327             ;; ntResponse field, 8 bytes
 328             ;;AddBytes(response,ntResponse,ntRespData,ln);
 329             (md4-pack-int16 ln) ;len field
 330             (md4-pack-int16 ln) ;maxlen field
 331             (md4-pack-int32 (cons 0 off-nt)) ;field offset
 332
 333             ;; uDomain field, 8 bytes
 334             ;;AddUnicodeString(response,uDomain,domain);
 335             ;;AddBytes(response, uDomain, udomain, 2*ld);
 336             (md4-pack-int16 (* 2 ld))   ;len field
 337             (md4-pack-int16 (* 2 ld))   ;maxlen field
 338             (md4-pack-int32 (cons 0 off-d)) ;field offset
 339
 340             ;; uUser field, 8 bytes
 341             ;;AddUnicodeString(response,uUser,u);
 342             ;;AddBytes(response, uUser, uuser, 2*lu);
 343             (md4-pack-int16 (* 2 lu))   ;len field
 344             (md4-pack-int16 (* 2 lu))   ;maxlen field
 345             (md4-pack-int32 (cons 0 off-u)) ;field offset
 346
 347             ;; uWks field, 8 bytes
 348             ;;AddUnicodeString(response,uWks,u);
 349             (md4-pack-int16 (* 2 lu))   ;len field
 350             (md4-pack-int16 (* 2 lu))   ;maxlen field
 351             (md4-pack-int32 (cons 0 off-w)) ;field offset
 352
 353             ;; sessionKey field, 8 bytes
 354             ;;AddString(response,sessionKey,NULL);
 355             (md4-pack-int16 0)          ;len field
 356             (md4-pack-int16 0)          ;maxlen field
 357             (md4-pack-int32 (cons 0 (- off-s off-lm))) ;field offset
 358
 359             ;; flags field, 4 bytes
 360             flags                       ;
 361
 362             ;; buffer field
 363             lmRespData                  ;lmResponse, 24 bytes
 364             ntRespData                  ;ntResponse, 24 bytes
 365             (ntlm-ascii2unicode domain  ;Unicode domain string, 2*ld bytes
 366                                 (length domain)) ;
 367             (ntlm-ascii2unicode user    ;Unicode user string, 2*lu bytes
 368                                 (length user)) ;
 369             (ntlm-ascii2unicode user    ;Unicode user string, 2*lu bytes
 370                                 (length user)) ;
 371             )))
 372
 373 (defun ntlm-get-password-hashes (password)
 374   "Return a pair of SMB hash and NT MD4 hash of the given password PASSWORD."
 375   (list (ntlm-smb-passwd-hash password)
 376         (ntlm-md4hash password)))
 377
 378 (defun ntlm-ascii2unicode (str len)
 379   "Convert an ASCII string into a NT Unicode string, which is
 380 little-endian utf16."
 381   (let ((utf (make-string (* 2 len) 0)) (i 0) val)
 382     (while (and (< i len)
 383                 (not (zerop (setq val (aref str i)))))
 384       (aset utf (* 2 i) val)
 385       (aset utf (1+ (* 2 i)) 0)
 386       (setq i (1+ i)))
 387     utf))
 388
 389 (defun ntlm-unicode2ascii (str len)
 390   "Extract 7 bits ASCII part of a little endian utf16 string STR of length LEN."
 391   (let ((buf (make-string len 0)) (i 0) (j 0))
 392     (while (< i len)
 393       (aset buf i (logand (aref str j) 127)) ;(string-to-number "7f" 16)
 394       (setq i (1+ i)
 395             j (+ 2 j)))
 396     buf))
 397
 398 (defun ntlm-smb-passwd-hash (passwd)
 399   "Return the SMB password hash string of 16 bytes long for the given password
 400 string PASSWD.  PASSWD is truncated to 14 bytes if longer."
 401   (let ((len (min (length passwd) 14)))
 402     (ntlm-smb-des-e-p16
 403      (concat (substring (upcase passwd) 0 len) ;fill top 14 bytes with passwd
 404              (make-string (- 15 len) 0)))))
 405
 406 (defun ntlm-smb-owf-encrypt (passwd c8)
 407   "Return the response string of 24 bytes long for the given password
 408 string PASSWD based on the DES encryption.  PASSWD is of at most 14
 409 bytes long and the challenge string C8 of 8 bytes long."
 410   (let ((len (min (length passwd) 16)) p22)
 411     (setq p22 (concat (substring passwd 0 len) ;fill top 16 bytes with passwd
 412                       (make-string (- 22 len) 0)))
 413     (ntlm-smb-des-e-p24 p22 c8)))
 414
 415 (defun ntlm-smb-des-e-p24 (p22 c8)
 416   "Return a 24 bytes hashed string for a 21 bytes string P22 and a 8 bytes
 417 string C8."
 418   (concat (ntlm-smb-hash c8 p22 t)              ;hash first 8 bytes of p22
 419           (ntlm-smb-hash c8 (substring p22 7) t)
 420           (ntlm-smb-hash c8 (substring p22 14) t)))
 421
 422 (defconst ntlm-smb-sp8 [75 71 83 33 64 35 36 37])
 423
 424 (defun ntlm-smb-des-e-p16 (p15)
 425   "Return a 16 bytes hashed string for a 15 bytes string P15."
 426   (concat (ntlm-smb-hash ntlm-smb-sp8 p15 t)    ;hash of first 8 bytes of p15
 427           (ntlm-smb-hash ntlm-smb-sp8           ;hash of last 8 bytes of p15
 428                          (substring p15 7) t)))
 429
 430 (defun ntlm-smb-hash (in key forw)
 431   "Return the hash string of length 8 for a string IN of length 8 and
 432 a string KEY of length 8.  FORW is t or nil."
 433   (let ((out (make-string 8 0))
 434         outb                            ;string of length 64
 435         (inb (make-string 64 0))
 436         (keyb (make-string 64 0))
 437         (key2 (ntlm-smb-str-to-key key))
 438         (i 0) aa)
 439     (while (< i 64)
 440       (unless (zerop (logand (aref in (/ i 8)) (lsh 1 (- 7 (% i 8)))))
 441         (aset inb i 1))
 442       (unless (zerop (logand (aref key2 (/ i 8)) (lsh 1 (- 7 (% i 8)))))
 443         (aset keyb i 1))
 444       (setq i (1+ i)))
 445     (setq outb (ntlm-smb-dohash inb keyb forw))
 446     (setq i 0)
 447     (while (< i 64)
 448       (unless (zerop (aref outb i))
 449         (setq aa (aref out (/ i 8)))
 450         (aset out (/ i 8)
 451               (logior aa (lsh 1 (- 7 (% i 8))))))
 452       (setq i (1+ i)))
 453     out))
 454
 455 (defun ntlm-smb-str-to-key (str)
 456   "Return a string of length 8 for the given string STR of length 7."
 457   (let ((key (make-string 8 0))
 458         (i 7))
 459     (aset key 0 (lsh (aref str 0) -1))
 460     (aset key 1 (logior
 461                  (lsh (logand (aref str 0) 1) 6)
 462                  (lsh (aref str 1) -2)))
 463     (aset key 2 (logior
 464                  (lsh (logand (aref str 1) 3) 5)
 465                  (lsh (aref str 2) -3)))
 466     (aset key 3 (logior
 467                  (lsh (logand (aref str 2) 7) 4)
 468                  (lsh (aref str 3) -4)))
 469     (aset key 4 (logior
 470                  (lsh (logand (aref str 3) 15) 3)
 471                  (lsh (aref str 4) -5)))
 472     (aset key 5 (logior
 473                  (lsh (logand (aref str 4) 31) 2)
 474                  (lsh (aref str 5) -6)))
 475     (aset key 6 (logior
 476                  (lsh (logand (aref str 5) 63) 1)
 477                  (lsh (aref str 6) -7)))
 478     (aset key 7 (logand (aref str 6) 127))
 479     (while (>= i 0)
 480       (aset key i (lsh (aref key i) 1))
 481       (setq i (1- i)))
 482     key))
 483
 484 (defconst ntlm-smb-perm1 [57 49 41 33 25 17  9
 485                      1 58 50 42 34 26 18
 486                      10  2 59 51 43 35 27
 487                      19 11  3 60 52 44 36
 488                      63 55 47 39 31 23 15
 489                      7 62 54 46 38 30 22
 490                      14  6 61 53 45 37 29
 491                      21 13  5 28 20 12  4])
 492
 493 (defconst ntlm-smb-perm2 [14 17 11 24  1  5
 494                      3 28 15  6 21 10
 495                      23 19 12  4 26  8
 496                      16  7 27 20 13  2
 497                      41 52 31 37 47 55
 498                      30 40 51 45 33 48
 499                      44 49 39 56 34 53
 500                      46 42 50 36 29 32])
 501
 502 (defconst ntlm-smb-perm3 [58 50 42 34 26 18 10  2
 503                      60 52 44 36 28 20 12  4
 504                      62 54 46 38 30 22 14  6
 505                      64 56 48 40 32 24 16  8
 506                      57 49 41 33 25 17  9  1
 507                      59 51 43 35 27 19 11  3
 508                      61 53 45 37 29 21 13  5
 509                      63 55 47 39 31 23 15  7])
 510
 511 (defconst ntlm-smb-perm4 [32  1  2  3  4  5
 512                      4  5  6  7  8  9
 513                      8  9 10 11 12 13
 514                      12 13 14 15 16 17
 515                      16 17 18 19 20 21
 516                      20 21 22 23 24 25
 517                      24 25 26 27 28 29
 518                      28 29 30 31 32  1])
 519
 520 (defconst ntlm-smb-perm5 [16  7 20 21
 521                      29 12 28 17
 522                      1 15 23 26
 523                      5 18 31 10
 524                      2  8 24 14
 525                      32 27  3  9
 526                      19 13 30  6
 527                      22 11  4 25])
 528
 529 (defconst ntlm-smb-perm6 [40  8 48 16 56 24 64 32
 530                      39  7 47 15 55 23 63 31
 531                      38  6 46 14 54 22 62 30
 532                      37  5 45 13 53 21 61 29
 533                      36  4 44 12 52 20 60 28
 534                      35  3 43 11 51 19 59 27
 535                      34  2 42 10 50 18 58 26
 536                      33  1 41  9 49 17 57 25])
 537
 538 (defconst ntlm-smb-sc [1 1 2 2 2 2 2 2 1 2 2 2 2 2 2 1])
 539
 540 (defconst ntlm-smb-sbox [[[14  4 13  1  2 15 11  8  3 10  6 12  5  9  0  7]
 541                      [ 0 15  7  4 14  2 13  1 10  6 12 11  9  5  3  8]
 542                      [ 4  1 14  8 13  6  2 11 15 12  9  7  3 10  5  0]
 543                      [15 12  8  2  4  9  1  7  5 11  3 14 10  0  6 13]]
 544                     [[15  1  8 14  6 11  3  4  9  7  2 13 12  0  5 10]
 545                      [ 3 13  4  7 15  2  8 14 12  0  1 10  6  9 11  5]
 546                      [ 0 14  7 11 10  4 13  1  5  8 12  6  9  3  2 15]
 547                      [13  8 10  1  3 15  4  2 11  6  7 12  0  5 14  9]]
 548                     [[10  0  9 14  6  3 15  5  1 13 12  7 11  4  2  8]
 549                      [13  7  0  9  3  4  6 10  2  8  5 14 12 11 15  1]
 550                      [13  6  4  9  8 15  3  0 11  1  2 12  5 10 14  7]
 551                      [ 1 10 13  0  6  9  8  7  4 15 14  3 11  5  2 12]]
 552                     [[ 7 13 14  3  0  6  9 10  1  2  8  5 11 12  4 15]
 553                      [13  8 11  5  6 15  0  3  4  7  2 12  1 10 14  9]
 554                      [10  6  9  0 12 11  7 13 15  1  3 14  5  2  8  4]
 555                      [ 3 15  0  6 10  1 13  8  9  4  5 11 12  7  2 14]]
 556                     [[ 2 12  4  1  7 10 11  6  8  5  3 15 13  0 14  9]
 557                      [14 11  2 12  4  7 13  1  5  0 15 10  3  9  8  6]
 558                      [ 4  2  1 11 10 13  7  8 15  9 12  5  6  3  0 14]
 559                      [11  8 12  7  1 14  2 13  6 15  0  9 10  4  5  3]]
 560                     [[12  1 10 15  9  2  6  8  0 13  3  4 14  7  5 11]
 561                      [10 15  4  2  7 12  9  5  6  1 13 14  0 11  3  8]
 562                      [ 9 14 15  5  2  8 12  3  7  0  4 10  1 13 11  6]
 563                      [ 4  3  2 12  9  5 15 10 11 14  1  7  6  0  8 13]]
 564                     [[ 4 11  2 14 15  0  8 13  3 12  9  7  5 10  6  1]
 565                      [13  0 11  7  4  9  1 10 14  3  5 12  2 15  8  6]
 566                      [ 1  4 11 13 12  3  7 14 10 15  6  8  0  5  9  2]
 567                      [ 6 11 13  8  1  4 10  7  9  5  0 15 14  2  3 12]]
 568                     [[13  2  8  4  6 15 11  1 10  9  3 14  5  0 12  7]
 569                      [ 1 15 13  8 10  3  7  4 12  5  6 11  0 14  9  2]
 570                      [ 7 11  4  1  9 12 14  2  0  6 10 13 15  3  5  8]
 571                      [ 2  1 14  7  4 10  8 13 15 12  9  0  3  5  6 11]]])
 572
 573 (defsubst ntlm-string-permute (in perm n)
 574   "Return a string of length N for a string IN and a permutation vector
 575 PERM of size N.  The length of IN should be height of PERM."
 576   (let ((i 0) (out (make-string n 0)))
 577     (while (< i n)
 578       (aset out i (aref in (- (aref perm i) 1)))
 579       (setq i (1+ i)))
 580     out))
 581
 582 (defsubst ntlm-string-lshift (str count len)
 583   "Return a string by circularly shifting a string STR by COUNT to the left.
 584 length of STR is LEN."
 585   (let ((c (% count len)))
 586     (concat (substring str c len) (substring str 0 c))))
 587
 588 (defsubst ntlm-string-xor (in1 in2 n)
 589   "Return exclusive-or of sequences in1 and in2"
 590   (let ((w (make-string n 0)) (i 0))
 591     (while (< i n)
 592       (aset w i (logxor (aref in1 i) (aref in2 i)))
 593       (setq i (1+ i)))
 594     w))
 595
 596 (defun ntlm-smb-dohash (in key forw)
 597   "Return the hash value for a string IN and a string KEY.
 598 Length of IN and KEY are 64.  FORW non-nil means forward, nil means
 599 backward."
 600   (let (pk1                             ;string of length 56
 601         c                               ;string of length 28
 602         d                               ;string of length 28
 603         cd                              ;string of length 56
 604         (ki (make-vector 16 0))         ;vector of string of length 48
 605         pd1                             ;string of length 64
 606         l                               ;string of length 32
 607         r                               ;string of length 32
 608         rl                              ;string of length 64
 609         (i 0) (j 0) (k 0))
 610     (setq pk1 (ntlm-string-permute key ntlm-smb-perm1 56))
 611     (setq c (substring pk1 0 28))
 612     (setq d (substring pk1 28 56))
 613
 614     (setq i 0)
 615     (while (< i 16)
 616       (setq c (ntlm-string-lshift c (aref ntlm-smb-sc i) 28))
 617       (setq d (ntlm-string-lshift d (aref ntlm-smb-sc i) 28))
 618       (setq cd (concat (substring c 0 28) (substring d 0 28)))
 619       (aset ki i (ntlm-string-permute cd ntlm-smb-perm2 48))
 620       (setq i (1+ i)))
 621
 622     (setq pd1 (ntlm-string-permute in ntlm-smb-perm3 64))
 623
 624     (setq l (substring pd1 0 32))
 625     (setq r (substring pd1 32 64))
 626
 627     (setq i 0)
 628     (let (er                            ;string of length 48
 629           erk                           ;string of length 48
 630           (b (make-vector 8 0))         ;vector of strings of length 6
 631           cb                            ;string of length 32
 632           pcb                           ;string of length 32
 633           r2                            ;string of length 32
 634           jj m n bj sbox-jmn)
 635       (while (< i 16)
 636         (setq er (ntlm-string-permute r ntlm-smb-perm4 48))
 637         (setq erk (ntlm-string-xor er
 638                        (aref ki (if forw i (- 15 i)))
 639                        48))
 640         (setq j 0)
 641         (while (< j 8)
 642           (setq jj (* 6 j))
 643           (aset b j (substring erk jj (+ jj 6)))
 644           (setq j (1+ j)))
 645         (setq j 0)
 646         (while (< j 8)
 647           (setq bj (aref b j))
 648           (setq m (logior (lsh (aref bj 0) 1) (aref bj 5)))
 649           (setq n (logior (lsh (aref bj 1) 3)
 650                           (lsh (aref bj 2) 2)
 651                           (lsh (aref bj 3) 1)
 652                           (aref bj 4)))
 653           (setq k 0)
 654           (setq sbox-jmn (aref (aref (aref ntlm-smb-sbox j) m) n))
 655           (while (< k 4)
 656             (aset bj k
 657                   (if (zerop (logand sbox-jmn (lsh 1 (- 3 k))))
 658                       0 1))
 659             (setq k (1+ k)))
 660           (setq j (1+ j)))
 661
 662         (setq j 0)
 663         (setq cb nil)
 664         (while (< j 8)
 665           (setq cb (concat cb (substring (aref b j) 0 4)))
 666           (setq j (1+ j)))
 667
 668         (setq pcb (ntlm-string-permute cb ntlm-smb-perm5 32))
 669         (setq r2 (ntlm-string-xor l pcb 32))
 670         (setq l r)
 671         (setq r r2)
 672         (setq i (1+ i))))
 673     (setq rl (concat r l))
 674     (ntlm-string-permute rl ntlm-smb-perm6 64)))
 675
 676 (defun ntlm-md4hash (passwd)
 677   "Return the 16 bytes MD4 hash of a string PASSWD after converting it
 678 into a Unicode string.  PASSWD is truncated to 128 bytes if longer."
 679   (let (len wpwd)
 680     ;; Password cannot be longer than 128 characters
 681     (setq len (length passwd))
 682     (if (> len 128)
 683         (setq len 128))
 684     ;; Password must be converted to NT Unicode
 685     (setq wpwd (ntlm-ascii2unicode passwd len))
 686     ;; Calculate length in bytes
 687     (setq len (* len 2))
 688     (md4 wpwd len)))
 689
 690 (provide 'ntlm)
 691
 692 ;;; ntlm.el ends here