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

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