[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/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