From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Thomas Fitzsimmons Newsgroups: gmane.emacs.devel Subject: [ELPA] New package: url-http-ntlm Date: Sun, 14 Feb 2016 15:43:38 -0500 Message-ID: NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: ger.gmane.org 1455482638 3316 80.91.229.3 (14 Feb 2016 20:43:58 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Sun, 14 Feb 2016 20:43:58 +0000 (UTC) To: emacs-devel@gnu.org Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Sun Feb 14 21:43:50 2016 Return-path: Envelope-to: ged-emacs-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1aV3WI-0003bZ-1X for ged-emacs-devel@m.gmane.org; Sun, 14 Feb 2016 21:43:50 +0100 Original-Received: from localhost ([::1]:53537 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1aV3WH-00056Z-4Q for ged-emacs-devel@m.gmane.org; Sun, 14 Feb 2016 15:43:49 -0500 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:39765) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1aV3WC-00055I-EM for emacs-devel@gnu.org; Sun, 14 Feb 2016 15:43:46 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1aV3W9-0000cG-4o for emacs-devel@gnu.org; Sun, 14 Feb 2016 15:43:44 -0500 Original-Received: from mail-ig0-x22f.google.com ([2607:f8b0:4001:c05::22f]:36147) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1aV3W8-0000c8-T2 for emacs-devel@gnu.org; Sun, 14 Feb 2016 15:43:41 -0500 Original-Received: by mail-ig0-x22f.google.com with SMTP id xg9so40333010igb.1 for ; Sun, 14 Feb 2016 12:43:40 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=fitzsim-org.20150623.gappssmtp.com; s=20150623; h=from:to:subject:date:message-id:mime-version:content-type; bh=q9+MnfcKINPj2PztczIZgZDE+jR9gmRI/T9KthHQ5PI=; b=Wp0Rd4kAzPg3HjVCig9UDWG4vfxrqz1R/QrTwiK574CZX8+WEUHs2q2iDtZ7Ft3+u+ a+b9xW8FHAez3m57By+tSolwMtE2gVwMHLDk0fiUIbotMscyJlG/+rVytEOZatg1NFH2 b3w247BDRhsb9Zc15C6TqsA2I76gg/hZme1+BkMv8wnSrnJlw46TreyREO4ENoO8h2Oy +scdvl+m1RFCgvaKKXhXJFDuWdncppzrIG44wZ4xK+XPH/j8TVT2G6ntkIj3XlnFebKq WEXsY68SZi+KdeBVsgFoJ6egL+iah3bOeOfamdbShXFhipJfUM0qnbSB9kMdaUS2CCMN RKRQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20130820; h=x-gm-message-state:from:to:subject:date:message-id:mime-version :content-type; bh=q9+MnfcKINPj2PztczIZgZDE+jR9gmRI/T9KthHQ5PI=; b=iA6eiw/rL9bzfK1Rb9sT6uOmRSLVMNvyfSBF0cIuCplFPm/VbilEg3hiWgTysLJxyl 6K5PAGXnCuhuxie1LdTA3abcf5ItS7yUqyNuz1WZNB3A5BK1e1/dyTSzRPCXV5wvck4z 4PREfVYxf9QwKjnUsIHJqOghnfMO7NzIciUfY2z4jCibXAZLUiTgGuYsoUYrJHaGeKKR s28itB/KHPOJ5hMrkB2wwJ4941GuUpaeWPPNE8zfvu1gX7VEXj/fWPtmSlTfU8LYP9qg mdvAoV79LfYVp9ZzBtYLCn+rBvsbGYDXHR7rt3Lp2wodVLwcO4F2BvDQHKpKnnC8NQQJ uP9A== X-Gm-Message-State: AG10YORL3YL29l8braStrinRuAFKisDjSswOXp+zlzd/HRYWs5QISrKqNNLz8NRatnUGbg== X-Received: by 10.50.59.242 with SMTP id c18mr8534753igr.48.1455482619874; Sun, 14 Feb 2016 12:43:39 -0800 (PST) Original-Received: from hp-dv5t (69-165-165-189.dsl.teksavvy.com. [69.165.165.189]) by smtp.gmail.com with ESMTPSA id h83sm9585625iod.4.2016.02.14.12.43.39 for (version=TLS1_2 cipher=ECDHE-RSA-AES128-GCM-SHA256 bits=128/128); Sun, 14 Feb 2016 12:43:39 -0800 (PST) X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 2607:f8b0:4001:c05::22f X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Original-Sender: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.emacs.devel:199942 Archived-At: --=-=-= Content-Type: text/plain Hi, This package provides a NTLM handler for the URL package. For versions of Emacs <= 24.5, this package applies a patch to the built-in url-http-parse-headers function. The patch is already applied to the emacs.git master and emacs-25 branches. The main author, Tom Schutzer-Weissmann, has signed FSF copyright assignment papers. Thanks, Thomas --=-=-= Content-Type: text/plain Content-Disposition: inline; filename=url-http-ntlm.el ;;; url-http-ntlm.el --- NTLM authentication for the url library ;; Copyright (C) 2008, 2016 Free Software Foundation, Inc. ;; Author: Tom Schutzer-Weissmann ;; Maintainer: Thomas Fitzsimmons ;; Version: 2.0.1 ;; 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 ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . ;;; Commentary: ;; ;; This package provides a NTLM handler for the URL package. ;; ;; Installation: ;; ;; M-x package-install RET url-http-ntlm RET ;; ;; Acknowledgements: ;; ;; Taro Kawagishi wrote ntlm.el and md4.el, ;; which are parts of FLIM (Faithful Library about Internet Message). ;; ;; http://stuff.mit.edu/afs/sipb/contrib/emacs/packages/flim-1.14.7/ntlm.el ;; http://stuff.mit.edu/afs/sipb/contrib/emacs/packages/flim-1.14.7/md4.el ;;; Code: (require 'url-auth) (require 'url-http) (require 'url-util) (require 'mail-parse) (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)))) ;;; 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'.") (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) (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).") (defvar url-http-ntlm--default-users nil "An alist that stores one default username per server.") ;;; 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-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." (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." (cl-declare (special url-http-extra-headers)) (setq url-http-extra-headers (url-http-ntlm--rmssoc "Authorization" url-http-extra-headers))) (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 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) (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 (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) (cl-destructuring-bind (challenge ntlm) args (and (string-equal "ntlm" (car ntlm)) (string-match challenge-rxp (car challenge))))) :response) (t :request)))) (url-http-ntlm--clean-headers) (setq url-http-ntlm--last-args (cons args stage)) stage)))) (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. REALM appears in the prompt. If URL contains a username and a password, they are used and 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)) (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--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 (cl-second (car stored))))) (not stored)) (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 (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--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 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. 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"))) (when (string-match "NTLM\\s-+\\(\\S-+\\)" www-authenticate) (base64-decode-string (match-string 1 www-authenticate)))))) (defun url-http-ntlm--rmssoc (key alist) "Remove all elements whose `car' match KEY from ALIST." (cl-remove key alist :key 'car :test 'equal)) (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) ;;; url-http-ntlm.el ends here --=-=-=--