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