X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/bc582f852dd771f2574da4228baea3eb38ca22d5..f10533854f4c7bb54247a11981191bf37b70cb36:/packages/url-http-ntlm/url-http-ntlm.el diff --git a/packages/url-http-ntlm/url-http-ntlm.el b/packages/url-http-ntlm/url-http-ntlm.el index 8cdb7e870..58622ad48 100644 --- a/packages/url-http-ntlm/url-http-ntlm.el +++ b/packages/url-http-ntlm/url-http-ntlm.el @@ -1,10 +1,13 @@ ;;; url-http-ntlm.el --- NTLM authentication for the url library -;; Copyright (C) 2008, 2015 Free Software Foundation, Inc. +;; Copyright (C) 2008, 2016 Free Software Foundation, Inc. ;; Author: Tom Schutzer-Weissmann ;; Maintainer: Thomas Fitzsimmons +;; Version: 2.0.2 ;; Keywords: comm, data, processes, hypermedia +;; Homepage: https://code.google.com/p/url-http-ntlm/ +;; Package-Requires: ((cl-lib "0.5") (ntlm "2.0.0")) ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -38,6 +41,7 @@ ;;; Code: (require 'url-auth) (require 'url-http) +(require 'url-util) (require 'mail-parse) (require 'cl-lib) (require 'ntlm) @@ -45,9 +49,25 @@ ;; 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)))) + (defvar url-http-ntlm--parsing-headers nil) + (defadvice url-http-parse-headers (around clear-authorization activate) + (let ((url-http-ntlm--parsing-headers t)) + ad-do-it)) + (defadvice url-http-handle-authentication (around clear-authorization + activate) + (let ((url-http-ntlm--parsing-headers nil)) + ad-do-it)) + (defadvice url-retrieve-internal (before clear-authorization activate) + (when (and url-http-ntlm--parsing-headers + (eq url-request-extra-headers url-http-extra-headers)) + ;; This retrieval is presumably in response to a redirect. + ;; Do not automatically include an authorization header in the + ;; redirect. If needed it will be regenerated by the relevant + ;; auth scheme when the new request happens. + (setq url-http-extra-headers + (cl-remove "Authorization" + url-http-extra-headers :key #'car :test #'equal)) + (setq url-request-extra-headers url-http-extra-headers)))) ;;; Private variables. @@ -59,7 +79,7 @@ hashes>\). The hashes are built using `ntlm-get-password-hashes'.") (defvar url-http-ntlm--last-args nil - "Stores the last `url-http-ntlm--get-stage' arguments and return value. + "The last `url-http-ntlm--get-stage' arguments and result. This is used to detect multiple calls.") (make-variable-buffer-local 'url-http-ntlm--last-args) @@ -68,8 +88,7 @@ This is used to detect multiple calls.") Keys are urls, entries are (START-TIME . COUNTER).") (defvar url-http-ntlm--default-users nil - "An alist that maps each server to the default username for -that server.") + "An alist that stores one default username per server.") ;;; Private functions. @@ -89,7 +108,7 @@ that server.") (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) + (url-http-ntlm--authorization url-string :clear) (remhash url-string url-http-ntlm--loop-timer-counter) (error (format (concat "Access rate to %s is too high," @@ -133,7 +152,7 @@ PROMPT and ARGS come from `url-ntlm-auth''s caller, `url-get-authentication'. Their meaning depends on the current implementation - this function is well and truly coupled. -url-get-authentication' calls `url-ntlm-auth' once when checking +`url-get-authentication' calls `url-ntlm-auth' once when checking what authentication schemes are supported (PROMPT and ARGS are nil), and then twice for every stage of the handshake: the first time PROMPT is nil, the second, t; ARGS contains the server @@ -145,9 +164,15 @@ response's \"WWW-Authenticate\" header, munged by (auth-header (assoc "Authorization" url-http-extra-headers)) (case-fold-search t) stage) + (url-debug 'url-http-ntlm "Buffer: %s" (current-buffer)) + (url-debug 'url-http-ntlm "Arguments: %s" args) + (url-debug 'url-http-ntlm "Previous arguments: %s" url-http-ntlm--last-args) (if (eq args (car url-http-ntlm--last-args)) ;; multiple calls, return the same argument we returned last time - (cdr url-http-ntlm--last-args) + (progn + (url-debug 'url-http-ntlm "Returning previous result: %s" + (cdr url-http-ntlm--last-args)) + (cdr url-http-ntlm--last-args)) (let ((stage (cond ((and auth-header (string-match response-rxp (cdr auth-header))) @@ -164,7 +189,7 @@ response's \"WWW-Authenticate\" header, munged by (setq url-http-ntlm--last-args (cons args stage)) stage)))) -(defun url-http-ntlm--authorisation (url &optional clear realm) +(defun url-http-ntlm--authorization (url &optional clear realm) "Get or clear NTLM authentication details for URL. If CLEAR is non-nil, clear any saved credentials for server. Otherwise, return the credentials, prompting the user if @@ -222,7 +247,8 @@ stored credentials are not affected." stored)))) (defun url-http-ntlm--get-challenge () - "Return the NTLM Type-2 message in the WWW-Authenticate header, if present." + "Return the NTLM Type-2 message in the WWW-Authenticate header. +Return nil if the NTLM Type-2 message is not present." (save-restriction (mail-narrow-to-head) (let ((www-authenticate (mail-fetch-field "www-authenticate"))) @@ -257,12 +283,13 @@ the server's last response. These are used by (url-http-ntlm--ensure-keepalive) (let* ((user-url (url-http-ntlm--ensure-user url)) (stage (url-http-ntlm--get-stage args))) + (url-debug 'url-http-ntlm "Stage: %s" stage) (cl-case stage ;; NTLM Type 1 message: the request (:request (url-http-ntlm--detect-loop user-url) (cl-destructuring-bind (&optional key hash) - (url-http-ntlm--authorisation user-url nil realm) + (url-http-ntlm--authorization user-url nil realm) (when (cl-third key) (url-http-ntlm--string (ntlm-build-auth-request (cl-second key) (cl-third key)))))) @@ -271,13 +298,13 @@ the server's last response. These are used by (url-http-ntlm--detect-loop user-url) (let ((challenge (url-http-ntlm--get-challenge))) (cl-destructuring-bind (key hash) - (url-http-ntlm--authorisation user-url nil realm) + (url-http-ntlm--authorization user-url nil realm) (url-http-ntlm--string (ntlm-build-auth-response challenge (cl-second key) hash))))) (:error - (url-http-ntlm--authorisation user-url :clear))))) + (url-http-ntlm--authorization user-url :clear))))) ;;; Register `url-ntlm-auth' HTTP authentication method.