From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!.POSTED!not-for-mail From: Jarno Malmari Newsgroups: gmane.emacs.devel Subject: [PATCH 2/3] Refactor digest authentication in url-auth Date: Thu, 8 Sep 2016 22:51:25 +0300 Message-ID: <1473364286-2650-3-git-send-email-jarno@malmari.fi> References: <87twljepn9.fsf@gnus.org> <1473364286-2650-1-git-send-email-jarno@malmari.fi> NNTP-Posting-Host: blaine.gmane.org X-Trace: blaine.gmane.org 1473365105 12640 195.159.176.226 (8 Sep 2016 20:05:05 GMT) X-Complaints-To: usenet@blaine.gmane.org NNTP-Posting-Date: Thu, 8 Sep 2016 20:05:05 +0000 (UTC) Cc: emacs-devel@gnu.org To: larsi@gnus.org Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Thu Sep 08 22:05:00 2016 Return-path: Envelope-to: ged-emacs-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by blaine.gmane.org with esmtp (Exim 4.84_2) (envelope-from ) id 1bi5Z3-0001Vv-W1 for ged-emacs-devel@m.gmane.org; Thu, 08 Sep 2016 22:04:50 +0200 Original-Received: from localhost ([::1]:53711 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1bi5Z0-0005ar-Sg for ged-emacs-devel@m.gmane.org; Thu, 08 Sep 2016 16:04:46 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:35979) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1bi5Mo-0001vw-Pp for emacs-devel@gnu.org; Thu, 08 Sep 2016 15:52:13 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1bi5Ml-0006U8-3r for emacs-devel@gnu.org; Thu, 08 Sep 2016 15:52:10 -0400 Original-Received: from out4-smtp.messagingengine.com ([66.111.4.28]:39443) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1bi5Mi-0006Pu-Pg for emacs-devel@gnu.org; Thu, 08 Sep 2016 15:52:07 -0400 Original-Received: from compute5.internal (compute5.nyi.internal [10.202.2.45]) by mailout.nyi.internal (Postfix) with ESMTP id 093E52068C; Thu, 8 Sep 2016 15:51:56 -0400 (EDT) Original-Received: from frontend1 ([10.202.2.160]) by compute5.internal (MEProxy); Thu, 08 Sep 2016 15:51:56 -0400 DKIM-Signature: v=1; a=rsa-sha1; c=relaxed/relaxed; d=malmari.fi; h=cc :date:from:in-reply-to:message-id:references:subject:to :x-sasl-enc:x-sasl-enc; s=mesmtp; bh=/TQF0ZzF98muph4zNiYBsdDVR1E =; b=A/DA1UzBLso8YXxfxEU2rZeIVeTqMCQPSjoH14UH/iYs1jwXPYviFWYqmIb 6bR2MzyxzKIU/p0JHN/2+nUfSAye/9SG4BowhBpmCx+bAxH3O2sAig/BwaPgayX+ f8d/oxQ/XCC0/me1YpAZiQGznCT6XHm++lpsTXxZIsliNDr0= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed/relaxed; d= messagingengine.com; h=cc:date:from:in-reply-to:message-id :references:subject:to:x-sasl-enc:x-sasl-enc; s=smtpout; bh=/TQF 0ZzF98muph4zNiYBsdDVR1E=; b=C9tnAL/Pz9nIDhbGpEfjG7GD6rpxxlpsRSjh eylgQSTMDntH99fSt60Tyb9UEHvuRClNBHAdN8YNZrEGRYGJ3pjA7wlzUDe4GcDm GExs4heJAsJRZcD5fUBBeemUvmpbiezZ4UxUEiNvHmxhPTcO0hhsNBhp1T8MB8XF gobcR3g= X-Sasl-enc: 45ccMk5hZrO/ik7uGQnJzEB4lAoZfGqRt5E4dNGMo1HA 1473364315 Original-Received: from vabi.peto.intranet (a88-113-156-118.elisa-laajakaista.fi [88.113.156.118]) by mail.messagingengine.com (Postfix) with ESMTPA id E36B6F29CF; Thu, 8 Sep 2016 15:51:54 -0400 (EDT) X-Mailer: git-send-email 2.7.0.25.gfc10eb5 In-Reply-To: <1473364286-2650-1-git-send-email-jarno@malmari.fi> X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 66.111.4.28 X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.21 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" Xref: news.gmane.org gmane.emacs.devel:207302 Archived-At: Add a few tests as now more features are testable via intermediate functions. Additionally, this refactoring fixed a bug where duplicate key entries were continously added in `url-digest-auth-storage' each time authenticated. --- lisp/url/url-auth.el | 340 ++++++++++++++++++++++++++++------------ test/lisp/url/url-auth-tests.el | 36 +++++ 2 files changed, 276 insertions(+), 100 deletions(-) diff --git a/lisp/url/url-auth.el b/lisp/url/url-auth.el index b2eceb0..59944af 100644 --- a/lisp/url/url-auth.el +++ b/lisp/url/url-auth.el @@ -143,107 +143,247 @@ url-digest-auth-storage keyed by the server name. The cdr of this is an assoc list based on the \"directory\" specified by the url we are looking up.") +(defsubst url-digest-auth-colonjoin (&rest args) + "Concatenate ARGS as strings with colon as a separator." + (mapconcat 'identity args ":")) + +(defsubst url-digest-auth-kd (data secret) + "Apply digest algorithm MD5 to DATA using SECRET as described in RFC 2617." + (md5 (url-digest-auth-colonjoin secret data))) + +(defsubst url-digest-auth-make-ha1 (user realm password) + "Compute hashed A1 value as described in RFC 2617. +USER, REALM, and PASSWORD are strings used to create the hash +from." + (md5 (url-digest-auth-colonjoin user realm password))) + +(defsubst url-digest-auth-make-ha2 (method digest-uri) + "Compute hashed A2 value as described in RFC 2617. +METHOD and DIGEST-URI are strings used to create the hash from." + (md5 (url-digest-auth-colonjoin method digest-uri))) + +(defsubst url-digest-auth-make-request-digest (ha1 ha2 nonce) + "Construct the request-digest without qop as described in RFC 2617. +Inputs for this are the hash strings HA1, HA2, and NONCE." + (url-digest-auth-kd (url-digest-auth-colonjoin nonce ha2) ha1)) + +(defsubst url-digest-auth-directory-id (url realm) + "Make an identifier to use for server keys. +The identifier is made either from URL's path or REALM." + (or realm (or (url-file-directory (url-filename url)) "/"))) + +(defsubst url-digest-auth-server-id (url) + "Make an identifier to user for selecting servers in key cache. +The identifier is made from URL's host and port." + (format "%s:%d" (url-host url) (url-port url))) + +(defun url-digest-auth-name-value-string (pairs) + "Concatenate name-value pairs in association list PAIRS. + +Output is formatted as \"name1=\\\"value1\\\", name2=\\\"value2\\\", ...\"" + (mapconcat (lambda (pair) + (format "%s=\"%s\"" + (symbol-name (car pair)) + (cdr pair))) + pairs ", ")) + +(defun url-digest-auth-source-creds (url) + "Find credentials for URL object from the Emacs auth-source. +Return value is a plist that has `:user' and `:secret' properties +if credentials were found. Otherwise nil." + (let ((server (url-digest-auth-server-id url)) + (type (url-type url))) + (list :user (url-do-auth-source-search server type :user) + :secret (url-do-auth-source-search server type :secret)))) + +(defun url-digest-prompt-creds (url realm &optional creds) + "Prompt credentials for URL and REALM, defaulting to CREDS. +CREDS is a plist that may have properties `:user' and `:secret'." + ;; Set explicitly in case creds were nil. This makes the second + ;; plist-put modify the same plist. + (setq creds + (plist-put creds :user + (read-string (url-auth-user-prompt url realm) + (or (plist-get creds :user) + (user-real-login-name))))) + (plist-put creds :secret + (read-passwd "Password: " nil (plist-get creds :secret)))) + +(defun url-digest-auth-directory-id-assoc (dirkey keylist) + "Find the best match in key list using a path or a realm. + +The string DIRKEY is either a path or a realm. The key list to +search through is the alist KEYLIST where car of each element is +either a path or a realm. Realms are searched for an exact +match. For paths, an ancestor is sufficient for a match." + (or + ;; check exact match first, realm or path + (assoc dirkey keylist) + ;; no partial matches for non-path, i.e. realm + (and (string-match "/" dirkey) + (let (match) + (while (and (null match) keylist) + (if (or + ;; any realm candidate matches (why?) + (not (string-match "/" (caar keylist))) + ;; parent directory matches + (string-prefix-p (caar keylist) dirkey)) + (setq match (car keylist)) + (setq keylist (cdr keylist)))) + match)))) + +(defun url-digest-cached-key (url realm) + "Find best match for URL and REALM from `url-digest-auth-storage'. +The return value is a list consisting of a realm (or a directory) +a user name, and hashed authentication tokens HA1 and HA2, +defined in RFC 2617. Modifying the contents of the returned list +will modify the cache variable `url-digest-auth-storage' itself." + (let ((serverid (url-digest-auth-server-id url)) + (dirid (url-digest-auth-directory-id url realm))) + (url-digest-auth-directory-id-assoc + dirid (cdr (assoc serverid url-digest-auth-storage))))) + +(defun url-digest-cache-key (key url) + "Add key to `url-digest-auth-storage'. +KEY has the same format as returned by `url-digest-cached-key'. +The key is added to cache hierarchy under server id, deduced from +URL." + (let ((serverid (url-digest-auth-server-id url))) + (push (list serverid key) url-digest-auth-storage))) + (defun url-digest-auth-create-key (username password realm method uri) - "Create a key for digest authentication method" - (let* ((info (if (stringp uri) - (url-generic-parse-url uri) - uri)) - (a1 (md5 (concat username ":" realm ":" password))) - (a2 (md5 (concat method ":" (url-filename info))))) - (list a1 a2))) - -(defun url-digest-auth (url &optional prompt overwrite realm args) - "Get the username/password for the specified URL. -If optional argument PROMPT is non-nil, ask for the username/password -to use for the URL and its descendants. If optional third argument -OVERWRITE is non-nil, overwrite the old username/password pair if it -is found in the assoc list. If REALM is specified, use that as the realm -instead of hostname:portnum." - (if args - (let* ((href (if (stringp url) - (url-generic-parse-url url) - url)) - (server (url-host href)) - (type (url-type href)) - (port (url-port href)) - (file (url-filename href)) - (enable-recursive-minibuffers t) - user pass byserv retval data) - (setq file (cond - (realm realm) - ((string-match "/$" file) file) - (t (url-file-directory file))) - server (format "%s:%d" server port) - byserv (cdr-safe (assoc server url-digest-auth-storage))) - (cond - ((and prompt (not byserv)) - (setq user (or - (url-do-auth-source-search server type :user) - (read-string (url-auth-user-prompt url realm) - (user-real-login-name))) - pass (or - (url-do-auth-source-search server type :secret) - (read-passwd "Password: ")) - url-digest-auth-storage - (cons (list server - (cons file - (setq retval - (cons user - (url-digest-auth-create-key - user pass realm - (or url-request-method "GET") - url))))) - url-digest-auth-storage))) - (byserv - (setq retval (cdr-safe (assoc file byserv))) - (if (and (not retval) ; no exact match, check directories - (string-match "/" file)) ; not looking for a realm - (while (and byserv (not retval)) - (setq data (car (car byserv))) - (if (or (not (string-match "/" data)) - (and - (>= (length file) (length data)) - (string= data (substring file 0 (length data))))) - (setq retval (cdr (car byserv)))) - (setq byserv (cdr byserv)))) - (if overwrite - (if (and (not retval) prompt) - (setq user (or - (url-do-auth-source-search server type :user) - (read-string (url-auth-user-prompt url realm) - (user-real-login-name))) - pass (or - (url-do-auth-source-search server type :secret) - (read-passwd "Password: ")) - retval (setq retval - (cons user - (url-digest-auth-create-key - user pass realm - (or url-request-method "GET") - url))) - byserv (assoc server url-digest-auth-storage)) - (setcdr byserv - (cons (cons file retval) (cdr byserv)))))) - (t (setq retval nil))) - (if retval - (if (cdr-safe (assoc "opaque" args)) - (let ((nonce (or (cdr-safe (assoc "nonce" args)) "nonegiven")) - (opaque (cdr-safe (assoc "opaque" args)))) - (format - (concat "Digest username=\"%s\", realm=\"%s\"," - "nonce=\"%s\", uri=\"%s\"," - "response=\"%s\", opaque=\"%s\"") - (nth 0 retval) realm nonce (url-filename href) - (md5 (concat (nth 1 retval) ":" nonce ":" - (nth 2 retval))) opaque)) - (let ((nonce (or (cdr-safe (assoc "nonce" args)) "nonegiven"))) - (format - (concat "Digest username=\"%s\", realm=\"%s\"," - "nonce=\"%s\", uri=\"%s\"," - "response=\"%s\"") - (nth 0 retval) realm nonce (url-filename href) - (md5 (concat (nth 1 retval) ":" nonce ":" - (nth 2 retval)))))))))) + "Create a key for digest authentication method. +The USERNAME and PASSWORD are the credentials for REALM and are +used in making a hashed value named HA1. The HTTP METHOD and URI +makes a second hashed value HA2. These hashes are used in making +the authentication key that can be stored without saving the +password in plain text. The return value is a list consisting of +hashed authentication tokens HA1 and HA2, defined in RFC 2617. + +For backward compatibility, URI is allowed to be a URL cl-struct +object." + (and username password realm + (list (url-digest-auth-make-ha1 username realm password) + (url-digest-auth-make-ha2 method (cond ((stringp uri) uri) + (t (url-filename uri))))))) + +(defun url-digest-auth-build-response (key url realm attrs) + "Compute authorization string for the given challenge using KEY. + +The strings looks like 'Digest name1=\"value1\", +name2=\"value2\", ...' + +Part of the challenge is already solved in a pre-computed KEY +which is list of realm (or directory), user name, HA1 and HA2 +values (see RFC 2617). + +Some fields are filled with the given object URL, string REALM, +and contents of alist ATTRS. + +ATTRS is expected to contain at least the server's \"nonce\" +value. It also might contain the optional \"opaque\" value." + (when key + (let ((user (nth 1 key)) + (ha1 (nth 2 key)) + (ha2 (nth 3 key)) + (digest-uri (url-filename url)) + (nonce (cdr-safe (assoc "nonce" attrs))) + (opaque (cdr-safe (assoc "opaque" attrs)))) + + (concat + "Digest " + (url-digest-auth-name-value-string + (append (list (cons 'username user) + (cons 'realm realm) + (cons 'nonce nonce) + (cons 'uri digest-uri) + (cons 'response (url-digest-auth-make-request-digest + ha1 ha2 nonce))) + + (if opaque (list (cons 'opaque opaque))))))))) + +(defun url-digest-find-creds (url prompt &optional realm) + "Find or ask credentials for URL. + +Primary method for finding credentials is from Emacs auth-source. +If password isn't found, and PROMPT is non-nil, allow to query +credentials via minibuffer. Optional REALM may be used when +prompting as a hint to the user. + +Return value is nil in case either user name or password wasn't +found. Otherwise, it's a plist containing `:user' and `:secret'. +Additional `:source' property denotes the origin of the +credentials and its value can be either symbol `authsource' or +`interactive'." + (let ((creds (url-digest-auth-source-creds url))) + + ;; if incomplete and prompt allowed, prompt the user + (if (and prompt + (or (null creds) + (null (plist-get creds :secret)))) + (progn + (setq creds (url-digest-prompt-creds url realm creds)) + (plist-put creds :source 'interactive)) + (plist-put creds :source 'authsource)) + + (and (plist-get creds :user) + (plist-get creds :secret) + creds))) + +(defun url-digest-find-new-key (url realm prompt) + "Find new key either from auth-source or interactively. +The key is looked for based on URL and REALM. If PROMPT is +non-nil, ask interactively in case credentials weren't found from +auth-source." + (let (creds) + (unwind-protect + (if (setq creds (url-digest-find-creds url prompt realm)) + (cons (url-digest-auth-directory-id url realm) + (cons (plist-get creds :user) + (url-digest-auth-create-key + (plist-get creds :user) + (plist-get creds :secret) + realm + (or url-request-method "GET") + (url-filename url))))) + (if (and creds + ;; Don't clear secret for `authsource' since it will + ;; corrupt any future fetches for it. + (not (eq (plist-get creds :source) 'authsource))) + (clear-string (plist-get creds :secret)))))) + +(defun url-digest-auth (url &optional prompt overwrite realm attrs) + "Get the HTTP Digest response string for the specified URL. + +If optional argument PROMPT is non-nil, ask for the username and +password to use for the URL and its descendants but only if one +cannot be found from cache. Look also in Emacs auth-source. + +If optional third argument OVERWRITE is non-nil, overwrite the +old credentials, if they're found in cache, with new ones from +user prompt or from Emacs auth-source. + +If REALM is specified, use that instead of the URL descendant +method to match cached credentials. + +Alist ATTRS contains additional attributes for the authentication +challenge such as nonce and opaque." + (if attrs + (let* ((href (if (stringp url) (url-generic-parse-url url) url)) + (enable-recursive-minibuffers t) + (key (url-digest-cached-key href realm))) + + (if (or (null key) overwrite) + (let ((newkey (url-digest-find-new-key href realm (cond + (key nil) + (t prompt))))) + (if (and newkey key overwrite) + (setcdr key (cdr newkey)) + (if (and newkey (null key)) + (url-digest-cache-key (setq key newkey) href))))) + + (if key + (url-digest-auth-build-response key href realm attrs))))) (defvar url-registered-auth-schemes nil "A list of the registered authorization schemes and various and sundry diff --git a/test/lisp/url/url-auth-tests.el b/test/lisp/url/url-auth-tests.el index a80349d..adabaf2 100644 --- a/test/lisp/url/url-auth-tests.el +++ b/test/lisp/url/url-auth-tests.el @@ -65,6 +65,42 @@ url-auth-test-challenges :expected-ha2 "b44272ea65ee4af7fb26c5dba58f6863" :expected-response "0d84884d967e04440efc77e9e2b5b561"))) +(ert-deftest url-auth-test-colonjoin () + "Check joining strings with `:'." + (should (string= (url-digest-auth-colonjoin) "")) + (should (string= (url-digest-auth-colonjoin nil) "")) + (should (string= (url-digest-auth-colonjoin nil nil nil) "::")) + (should (string= (url-digest-auth-colonjoin "") "")) + (should (string= (url-digest-auth-colonjoin "" "") ":")) + (should (string= (url-digest-auth-colonjoin "one") "one")) + (should (string= (url-digest-auth-colonjoin "one" "two" "three") "one:two:three"))) + +(ert-deftest url-auth-test-digest-ha1 () + "Check HA1 computation." + (dolist (row url-auth-test-challenges) + (should (string= (url-digest-auth-make-ha1 (plist-get row :username) + (plist-get row :realm) + (plist-get row :password)) + (plist-get row :expected-ha1) + )))) + +(ert-deftest url-auth-test-digest-ha2 () + "Check HA2 computation." + (dolist (row url-auth-test-challenges) + (should (string= (url-digest-auth-make-ha2 (plist-get row :method) + (plist-get row :uri)) + (plist-get row :expected-ha2))))) + +(ert-deftest url-auth-test-digest-request-digest () + "Check digest response value when not supporting `qop'." + (dolist (row url-auth-test-challenges) + (should (string= (url-digest-auth-make-request-digest + ;; HA1 and HA2 already tested + (plist-get row :expected-ha1) + (plist-get row :expected-ha2) + (plist-get row :nonce)) + (plist-get row :expected-response))))) + (ert-deftest url-auth-test-digest-create-key () "Check user credentials in their hashed form." (dolist (challenge url-auth-test-challenges) -- 2.7.0.25.gfc10eb5