(require 'url-auth)
(require 'url-http)
(require 'mail-parse)
-(require 'cl)
+(require 'cl-lib)
(require 'ntlm)
+;; Remove authorization after redirect.
+(when (and (boundp 'emacs-major-version)
+ (< emacs-major-version 25))
+ (require (intern (format "url-http-ntlm-parse-headers-%d.%d"
+ emacs-major-version
+ emacs-minor-version))))
+
\f
;;; Private variables.
(defvar url-http-ntlm--auth-storage nil
This is used to detect multiple calls.")
(make-variable-buffer-local 'url-http-ntlm--last-args)
+(defvar url-http-ntlm--loop-timer-counter nil
+ "A hash table used to detect NTLM negotiation errors.
+Keys are urls, entries are (START-TIME . COUNTER).")
+
\f
;;; Private functions.
+(defun url-http-ntlm--detect-loop (url)
+ "Detect potential infinite loop when NTLM fails on URL."
+ (when (not url-http-ntlm--loop-timer-counter)
+ (setq url-http-ntlm--loop-timer-counter (make-hash-table :test 'equal)))
+ (let* ((url-string (url-recreate-url url))
+ (last-entry (gethash url-string url-http-ntlm--loop-timer-counter))
+ (start-time (car last-entry))
+ (counter (cdr last-entry)))
+ (if last-entry
+ (progn
+ (if (< (- (float-time) start-time) 10.0)
+ (if (< counter 20)
+ ;; Still within time window, so increment count.
+ (puthash url-string (cons start-time (1+ counter))
+ url-http-ntlm--loop-timer-counter)
+ ;; Error detected, so remove entry and clear.
+ (url-http-ntlm--authorisation url-string :clear)
+ (remhash url-string url-http-ntlm--loop-timer-counter)
+ (error
+ (format (concat "Access rate to %s is too high,"
+ " indicating an NTLM failure;"
+ " to debug, re-run with url-debug set to 1")
+ url-string)))
+ ;; Timeout expired, so reset counter.
+ (puthash url-string (cons (float-time) 0)
+ url-http-ntlm--loop-timer-counter)))
+ ;; New access, so initialize counter to 0.
+ (puthash url-string (cons (float-time) 0)
+ url-http-ntlm--loop-timer-counter))))
+
(defun url-http-ntlm--ensure-keepalive ()
"Report an error if `url-http-attempt-keepalives' is not set."
- (assert url-http-attempt-keepalives
- nil
- (concat "NTLM authentication won't work unless"
- " `url-http-attempt-keepalives' is set!")))
+ (cl-assert url-http-attempt-keepalives
+ nil
+ (concat "NTLM authentication won't work unless"
+ " `url-http-attempt-keepalives' is set!")))
(defun url-http-ntlm--clean-headers ()
"Remove Authorization element from `url-http-extra-headers' alist."
(cdr auth-header)))
:error)
((and (= (length args) 2)
- (destructuring-bind (challenge ntlm) args
+ (cl-destructuring-bind (challenge ntlm) args
(and (string-equal "ntlm" (car ntlm))
(string-match challenge-rxp
(car challenge)))))
nil)
;; get
(if (or both
- (and stored user (not (equal user (second stored))))
+ (and stored user (not (equal user (cl-second stored))))
(not stored))
(let* ((user* (if both
user
(defun url-http-ntlm--rmssoc (key alist)
"Remove all elements whose `car' match KEY from ALIST."
- (remove* key alist :key 'car :test 'equal))
+ (cl-remove key alist :key 'car :test 'equal))
(defun url-http-ntlm--string (data)
"Return DATA encoded as an NTLM string."
`url-http-get-stage' to determine what stage we are at."
(url-http-ntlm--ensure-keepalive)
(let ((stage (url-http-ntlm--get-stage args)))
- (case stage
+ (cl-case stage
;; NTLM Type 1 message: the request
(:request
- (destructuring-bind (&optional server user hash)
+ (url-http-ntlm--detect-loop user-url)
+ (cl-destructuring-bind (&optional server user hash)
(url-http-ntlm--authorisation url)
(when server
(url-http-ntlm--string
(ntlm-build-auth-request user server)))))
;; NTLM Type 3 message: the response
(:response
+ (url-http-ntlm--detect-loop user-url)
(let ((challenge (url-http-ntlm--get-challenge)))
- (destructuring-bind (server user hash)
+ (cl-destructuring-bind (server user hash)
(url-http-ntlm--authorisation url)
(url-http-ntlm--string
(ntlm-build-auth-response challenge