X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/cec498235ef5601ac054d5df5533366e4e0d4f80..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 a5798ea87..58622ad48 100644 --- a/packages/url-http-ntlm/url-http-ntlm.el +++ b/packages/url-http-ntlm/url-http-ntlm.el @@ -1,9 +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 +;; 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 @@ -21,16 +25,10 @@ ;;; Commentary: ;; ;; This package provides a NTLM handler for the URL package. -;; It supports one username and password per server. ;; ;; Installation: ;; -;; Add the directory containing this file to the load path and then -;; load the url-http-ntlm package. One way would be to add something -;; like the lines below to your .emacs file: -;; -;; (add-to-list 'load-path ".emacs.d/url-http-ntlm") -;; (require 'url-http-ntlm) +;; M-x package-install RET url-http-ntlm RET ;; ;; Acknowledgements: ;; @@ -43,156 +41,214 @@ ;;; Code: (require 'url-auth) (require 'url-http) +(require 'url-util) (require 'mail-parse) -(require 'cl) +(require 'cl-lib) (require 'ntlm) -(defvar url-http-ntlm-auth-storage nil +;; Remove authorization after redirect. +(when (and (boundp 'emacs-major-version) + (< emacs-major-version 25)) + (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. +(defvar url-http-ntlm--auth-storage nil "Authentication storage. An alist that maps a server name to a pair of \( \). -The hashes are built using `ntlm-get-password-hashes'. -The username can contain the domain name, in the form \"user@domain\". +The hashes are built using `ntlm-get-password-hashes'.") -Note that for any server, only one user and password is ever stored.") +(defvar url-http-ntlm--last-args nil + "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) -(defun url-ntlm-auth (url &optional prompt overwrite realm args) - "Return an NTLM HTTP authorization header. -Get the contents of the Authorization header for a HTTP response -using NTLM authentication, to access URL. Because NTLM is a -two-step process, this function expects to be called twice, first -to generate the NTLM type 1 message (request), then to respond to -the server's type 2 message (challenge) with a suitable response. +(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).") -PROMPT, OVERWRITE, and REALM are ignored. +(defvar url-http-ntlm--default-users nil + "An alist that stores one default username per server.") -ARGS is expected to contain the WWW-Authentication header from -the server's last response. These are used by -`url-http-get-stage' to determine what stage we are at." - (url-ntlm-ensure-keepalive) - (let ((stage (url-ntlm-get-stage args))) - (case stage - ;; NTLM Type 1 message: the request - (:request - (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 - (let ((challenge (url-http-ntlm-get-challenge))) - (destructuring-bind (server user hash) - (url-http-ntlm-authorisation url) - (url-http-ntlm-string - (ntlm-build-auth-response challenge - user - hash))))) - (:error - (url-http-ntlm-authorisation url :clear))))) + +;;; 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--authorization 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-ntlm-ensure-keepalive () +(defun url-http-ntlm--ensure-user (url) + "Return URL with its user slot set. +If URL's user slot is nil, set it to the last user that made a +request to the host in URL's server slot." + (let ((new-url url)) + (if (url-user new-url) + new-url + (setf (url-user new-url) + (cdr (assoc (url-host new-url) url-http-ntlm--default-users))) + new-url))) + +(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-ntlm-clean-headers () +(defun url-http-ntlm--clean-headers () "Remove Authorization element from `url-http-extra-headers' alist." + (cl-declare (special url-http-extra-headers)) (setq url-http-extra-headers - (url-http-ntlm-rmssoc "Authorization" url-http-extra-headers))) - -(defvar url-ntlm-last-args nil - "Stores the last ARGS argument to `url-ntlm-get-stage' and the return value. -This is used to detect multiple calls.") -(make-variable-buffer-local 'url-ntlm-last-args) + (url-http-ntlm--rmssoc "Authorization" url-http-extra-headers))) -(defun url-ntlm-get-stage (args) +(defun url-http-ntlm--get-stage (args) "Determine what stage of the NTLM handshake we are at. 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 response's \"WWW-Authenticate\" header, munged by `url-parse-args'." + (cl-declare (special url-http-extra-headers)) (let* ((response-rxp "^NTLM TlRMTVNTUAADAAA") (challenge-rxp "^TLRMTVNTUAACAAA") (auth-header (assoc "Authorization" url-http-extra-headers)) (case-fold-search t) stage) - (if (eq args (car url-ntlm-last-args)) + (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-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))) :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))))) :response) (t :request)))) - (url-ntlm-clean-headers) - (setq url-ntlm-last-args (cons args stage)) + (url-http-ntlm--clean-headers) + (setq url-http-ntlm--last-args (cons args stage)) stage)))) -(defun url-http-ntlm-authorisation (url &optional clear) +(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 -necessary. +necessary. REALM appears in the prompt. If URL contains a username and a password, they are used and -stored credentials are not affected. - -Note that for any server, only one user and password is ever -stored." - (let* ((href (if (stringp url) +stored credentials are not affected." + (let* ((href (if (stringp url) (url-generic-parse-url url) url)) + (type (url-type href)) + (user (url-user href)) (server (url-host href)) - (user (url-user href)) - (pass (url-password href)) - (stored (assoc server url-http-ntlm-auth-storage)) - (both (and user pass))) + (port (url-portspec href)) + (pass (url-password href)) + (stored (assoc (list type user server port) + url-http-ntlm--auth-storage)) + (both (and user pass))) (if clear ;; clear (unless both - (setq url-http-ntlm-auth-storage - (url-http-ntlm-rmssoc server url-http-ntlm-auth-storage)) + (setq url-http-ntlm--default-users + (url-http-ntlm--rmssoc server url-http-ntlm--default-users)) + (setq url-http-ntlm--auth-storage + (url-http-ntlm--rmssoc '(type user* server port) + url-http-ntlm--auth-storage)) nil) ;; get (if (or both - (and stored user (not (equal user (second stored)))) + (and stored user (not (equal user (cl-second (car stored))))) (not stored)) - (let* ((user* (if both - user - (read-string (url-auth-user-prompt url realm) - (or user (user-real-login-name))))) + (let* ((user* (or user + (url-do-auth-source-search server type :user) + (read-string (url-auth-user-prompt url realm) + (or user (user-real-login-name))))) (pass* (if both pass - (read-passwd "Password: "))) - (entry `(,server . (,user* - ,(ntlm-get-password-hashes pass*))))) + (or (url-do-auth-source-search server type :secret) + (read-passwd (format "Password [for %s]: " + (url-recreate-url url)))))) + (key (list type user* server port)) + (entry `(,key . (,(ntlm-get-password-hashes pass*))))) (unless both - (setq url-http-ntlm-auth-storage + (setq url-http-ntlm--default-users + (cons + `(,server . ,user*) + (url-http-ntlm--rmssoc server + url-http-ntlm--default-users))) + (setq url-http-ntlm--auth-storage (cons entry - (url-http-ntlm-rmssoc server - url-http-ntlm-auth-storage)))) + (url-http-ntlm--rmssoc + key + url-http-ntlm--auth-storage)))) entry) stored)))) -(defun url-http-ntlm-get-challenge () - "Return the NTLM Type-2 message in the WWW-Authenticate header, if present." +(defun url-http-ntlm--get-challenge () + "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"))) @@ -200,14 +256,59 @@ stored." www-authenticate) (base64-decode-string (match-string 1 www-authenticate)))))) -(defun url-http-ntlm-rmssoc (key alist) +(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) +(defun url-http-ntlm--string (data) "Return DATA encoded as an NTLM string." (concat "NTLM " (base64-encode-string data :nobreak))) + +;;; Public function called by `url-get-authentication'. +;;;###autoload +(defun url-ntlm-auth (url &optional prompt overwrite realm args) + "Return an NTLM HTTP authorization header. +Get the contents of the Authorization header for a HTTP response +using NTLM authentication, to access URL. Because NTLM is a +two-step process, this function expects to be called twice, first +to generate the NTLM type 1 message (request), then to respond to +the server's type 2 message (challenge) with a suitable response. + +PROMPT, OVERWRITE, and REALM are ignored. + +ARGS is expected to contain the WWW-Authentication header from +the server's last response. These are used by +`url-http-get-stage' to determine what stage we are at." + (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--authorization user-url nil realm) + (when (cl-third key) + (url-http-ntlm--string + (ntlm-build-auth-request (cl-second key) (cl-third key)))))) + ;; NTLM Type 3 message: the response + (:response + (url-http-ntlm--detect-loop user-url) + (let ((challenge (url-http-ntlm--get-challenge))) + (cl-destructuring-bind (key hash) + (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--authorization user-url :clear))))) + + +;;; Register `url-ntlm-auth' HTTP authentication method. +;;;###autoload (url-register-auth-scheme "ntlm" nil 8) (provide 'url-http-ntlm)