[PATCH 2/3] Refactor digest authentication in url-auth

[Jarno Malmari <jarno@malmari.fi>]

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/automated/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 58bf45b..17c98af 100644
--- a/lisp/url/url-auth.el
+++ b/lisp/url/url-auth.el
@@ -140,107 +140,247 @@ Its value is an assoc list of assoc lists.  The first assoc list is
 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/automated/url-auth-tests.el b/test/automated/url-auth-tests.el
index 715308c..462d5f2 100644
--- a/test/automated/url-auth-tests.el
+++ b/test/automated/url-auth-tests.el
@@ -63,6 +63,42 @@ server's WWW-Authenticate header field.")
              :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.1.0.GIT