[elpa] externals/url-http-oauth 0bf4a7633d 08/24: Complete confidential client support

[Thomas Fitzsimmons]

branch: externals/url-http-oauth
commit 0bf4a7633d6ca1958323500c00fdd82efe4f11ff
Author: Thomas Fitzsimmons <fitzsim@fitzsim.org>
Commit: Thomas Fitzsimmons <fitzsim@fitzsim.org>

    Complete confidential client support
    
    * url-http-oauth.el: Remove mml-url requirement.  Remove
    development comments.
    (url-http-oauth-configuration): Allow user and scope in URL
    itself.
    (url-http-oauth-register-resource): Remove scope argument.  Rename
    some variables.
    (url-http-oauth-get-access-token-grant): Rename.  Implement
    auth-source saving.
    (url-http-oauth-expiry-string): New function.
    (url-http-oauth-extract-authorization-code): Reimplement using
    url-parse-query-string.
    (url-http-oauth-get-bearer): Do not cache auth-source queries.
    (url-oauth-auth): Remove a debug message.
---
 url-http-oauth.el | 233 ++++++++++++++++++++++++++++--------------------------
 1 file changed, 122 insertions(+), 111 deletions(-)

diff --git a/url-http-oauth.el b/url-http-oauth.el
index 382d26b35f..4852bab2f3 100644
--- a/url-http-oauth.el
+++ b/url-http-oauth.el
@@ -31,11 +31,7 @@
 (require 'url-auth)
 (require 'url-http)
 (require 'url-util)
-(require 'mm-url)
 
-;; For evaluation during development:
-;; (setq url-http-oauth--registered-oauth-urls nil)
-;; (message "%S" url-http-oauth--registered-oauth-urls)
 (defvar url-http-oauth--registered-oauth-urls nil
   "A hash table mapping URL strings to lists of OAuth 2.0 configuration.")
 
@@ -50,18 +46,25 @@
 (defun url-http-oauth-configuration (url)
   "Return a configuration list if URL needs OAuth 2.0, nil otherwise.
 URL is either a URL object or a URL string."
-  (let ((key (url-http-oauth-url-string url)))
-    (gethash key url-http-oauth--registered-oauth-urls)))
+  (when url-http-oauth--registered-oauth-urls
+    (let* ((url-no-query (url-parse-make-urlobj
+                          (url-type url)
+                          nil nil
+                          (url-host url)
+                          (url-portspec url)
+                          (car (url-path-and-query url))
+                          nil nil t))
+           (key (url-http-oauth-url-string url-no-query)))
+      (gethash key url-http-oauth--registered-oauth-urls))))
 
 ;; Maybe if RFC 8414, "OAuth 2.0 Authorization Server Metadata",
 ;; catches on, authorization-url and access-token-url can be made
-;; optional, and their values retrieved automatically.  But from what
-;; I can tell RFC 8414 is not consistently implemented yet.
+;; optional and their values retrieved automatically.  As of early
+;; 2023, RFC 8414 is not consistently implemented yet.
 (defun url-http-oauth-register-resource (url
                                          authorization-url
                                          access-token-url
                                          client-identifier
-                                         scope
                                          &optional
                                          client-secret-required)
   "Tell Emacs that to access URL, it needs to use OAuth 2.0.
@@ -69,19 +72,17 @@ URL will be accessed by Emacs's `url' library with a 
suitable
 \"Authorization\" header containing \"Bearer <token>\".
 AUTHORIZATION-URL and ACCESS-TOKEN-URL will be used to acquire
 <token> and save it to the user's `auth-source' file.  URL,
-AUTHORIZATION-URL and ACCESS-TOKEN-URL are either URL objects or
-URL strings.  CLIENT-IDENTIFIER is a string identifying an Emacs
-library or mode to the server.  SCOPE is a string defining the
-permissions that the Emacs library or mode is requesting.
-CLIENT-SECRET-REQUIRED is the symbol `prompt' if a client secret
-is required, nil otherwise."
+AUTHORIZATION-URL and ACCESS-TOKEN-URL are either objects or
+strings.  CLIENT-IDENTIFIER is a string identifying an Emacs
+library or mode to the server.  CLIENT-SECRET-REQUIRED is the
+symbol `prompt' if a client secret is required, nil otherwise."
   (unless url-http-oauth--registered-oauth-urls
     (setq url-http-oauth--registered-oauth-urls
           (make-hash-table :test #'equal)))
   (let ((key (url-http-oauth-url-string url))
         (authorization (url-http-oauth-url-string authorization-url))
-        (access-token (url-http-oauth-url-string access-token-url)))
-    (puthash key (list authorization access-token client-identifier scope
+        (access-token-object (url-http-oauth-url-object access-token-url)))
+    (puthash key (list authorization access-token-object client-identifier
                        (cond
                         ((eq client-secret-required 'prompt) 'prompt)
                         ((eq client-secret-required nil) nil)
@@ -89,148 +90,158 @@ is required, nil otherwise."
                             "Unrecognized client-secret-required value"))))
              url-http-oauth--registered-oauth-urls)))
 
-;; (car (auth-source-search :host "https://meta.sr.ht/oauth2/access-token"; 
:login "107ba4a9-2a96-4420-8818-84ec1f112405" :max 1))
+(defun url-http-oauth-unregister-resource (url)
+  "Tell Emacs not to use OAuth 2.0 when accessing URL.
+URL is either an objects or a string."
+  (when url-http-oauth--registered-oauth-urls
+    (remhash (url-http-oauth-url-string url)
+             url-http-oauth--registered-oauth-urls)))
 
 (defvar url-http-response-status)
+(defvar auth-source-creation-prompts)
+
+(defun url-http-oauth-port (url)
+  "Return port of URL object.
+Assume an HTTPS URL that does not specify a port uses 443."
+  (or (url-port url) (when (string= "https" (url-type url)) 443)))
 
-(defun url-http-oauth-get-access-token (url code)
+(defun url-http-oauth-get-access-token-grant (url code)
   "Get an access token for URL using CODE."
   (let* ((url-request-method "POST")
-         (key-url (url-http-oauth-url-string url))
-         (url-list (url-http-oauth-configuration key-url))
-         (access-token-url (nth 1 url-list))
+         (url-list (url-http-oauth-configuration url))
+         (access-token-object (nth 1 url-list))
          (client-identifier (nth 2 url-list))
-         (client-secret-required (nth 4 url-list))
-         (client-secret-current (when client-secret-required
-                                  (auth-info-password
-                                   (car (auth-source-search
-                                         :host access-token-url
-                                         ;; FIXME: Why doesn't :user
-                                         ;; work here, but :login
-                                         ;; does?
-                                         :login client-identifier
-                                         :max 1)))))
-         (client-secret-read (unless client-secret-current
-                               (when client-secret-required
-                                 (read-from-minibuffer
-                                  (format "Client secret for %s at %s: "
-                                          client-identifier key-url)))))
+         (client-secret-required (nth 3 url-list))
+         (auth-result
+          (when client-secret-required
+            (car (let ((auth-source-creation-prompts
+                        '((secret . "Client secret for %u at %h")))
+                       ;; Do not cache nil result.
+                       (auth-source-do-cache nil))
+                   (auth-source-search
+                    :user client-identifier
+                    :host (url-host access-token-object)
+                    :port (url-http-oauth-port access-token-object)
+                    :path (url-filename access-token-object)
+                    :create '(path)
+                    :max 1)))))
+         (client-secret (auth-info-password auth-result))
+         (save-function (plist-get auth-result :save-function))
          (authorization (concat
                          "Basic "
                          (base64-encode-string
-                          (format "%s:%s" client-identifier
-                                  (or client-secret-current client-secret-read
-                                      ;; FIXME what to do if not required?
-                                      ""))
+                          (if client-secret
+                              (format "%s:%s" client-identifier client-secret)
+                            ;; FIXME: what to do if client-secret not required?
+                            (format "%s" client-identifier))
                           t)))
          (url-request-extra-headers
           (list (cons "Content-Type" "application/x-www-form-urlencoded")
                 (cons "Authorization" authorization)))
          (url-request-data
-          (mm-url-encode-www-form-urlencoded
-           (list (cons "grant_type" "authorization_code")
-                 (cons "code" code)))))
-    (with-current-buffer (url-retrieve-synchronously access-token-url)
+          (url-build-query-string
+           (list (list "grant_type" "authorization_code")
+                 (list "code" code)))))
+    (with-current-buffer (url-retrieve-synchronously access-token-object)
       (if (eq 'OK (car (alist-get url-http-response-status url-http-codes)))
           (progn
-            (message "BUFFER-STRING: %s" (buffer-string)) ; FIXME: remove 
after testing.
             (goto-char (point-min))
             (re-search-forward "\n\n")
             (let* ((grant (json-parse-buffer))
                    (type (gethash "token_type" grant)))
-              (message "GRANT: %S" grant) ; FIXME: remove after testing.
               (unless (equal type "bearer" )
                 (error "Unrecognized token type %s for %s at %s" type
-                       client-identifier key-url))
+                       client-identifier (url-http-oauth-url-string url)))
               ;; Success, so save client secret, if necessary.
-              (when (and (not client-secret-current)
-                         client-secret-read)
-                (let* ((auth-result (auth-source-search
-                                     :host access-token-url
-                                     ;; FIXME: Why does :user here get
-                                     ;; translated to "login" in
-                                     ;; authinfo.gpg?
-                                     :user client-identifier
-                                     :secret client-secret-read
-                                     :create t))
-                       (save-function (plist-get (car auth-result)
-                                                 :save-function)))
-                  (if (functionp save-function)
-                      (funcall save-function)
-                    (warn "Saving client secret for %s at %s failed"
-                          client-identifier key-url))))
-              ;; Return access token string.
-              (gethash "access_token" grant)))
+              (when (functionp save-function)
+                (funcall save-function))
+              ;; Return grant object.
+              grant))
         (error "url-http-oauth: Failed to get access token with %s"
                (buffer-string))))))
 
+(defun url-http-oauth-expiry-string (grant)
+  "Return as a string a number representing the expiry time of GRANT.
+The time is in seconds since the epoch."
+  (format-time-string "%s" (time-add nil (gethash "expires_in" grant))))
+
 (defun url-http-oauth-extract-authorization-code (url)
   "Extract the value of the code parameter in URL."
-  (let* ((filename (url-filename (url-generic-parse-url url)))
-         (query-index (string-search "?" filename)))
-    (unless query-index
-      (error "Expected a URL with a query component after a `?' character"))
-    (let* ((query (substring filename (1+ query-index)))
-           (code
-            (catch 'found
-              (dolist (parameter (string-split query "&" t))
-                (let ((pair (split-string parameter "=")))
-                  (when (equal (car pair) "code")
-                    (throw 'found (cadr pair))))))))
+  (let ((query (cdr (url-path-and-query (url-generic-parse-url url)))))
+    (unless query
+      (error "url-http-oauth: Expected URL with query component"))
+    (let ((code (cadr (assoc "code" (url-parse-query-string query)))))
       (unless code
-        (error "Could not find code in pasted URL"))
+        (error "url-http-oauth: Failed to find code in query component"))
       code)))
 
 (defun url-http-oauth-get-bearer (url)
-  "Prompt the user with the authorization endpoint for URL."
-  (let* ((key-url (url-http-oauth-url-string url))
+  "Prompt the user with the authorization endpoint for URL.
+URL is a parsed object."
+  (let* ((path-and-query (url-path-and-query url))
+         (path (car path-and-query))
+         (query (cdr path-and-query))
+         (scope (cadr (assoc "scope" (url-parse-query-string query))))
          (bearer-current (auth-info-password
-                          (car (auth-source-search
-                                :host key-url
-                                :user user-login-name
-                                :max 1)))))
+                          (car
+                           (let ((auth-source-do-cache nil))
+                             (auth-source-search
+                              :user (url-user url)
+                              :host (url-host url)
+                              :port (url-http-oauth-port url)
+                              :path path
+                              :scope scope
+                              :max 1))))))
     (or bearer-current
-        (let ((url-list (url-http-oauth-configuration key-url)))
+        (let ((url-list (url-http-oauth-configuration url)))
           (unless url-list
-            (error "%s is not registered with url-http-oauth" key-url))
+            (error "%s is not registered with url-http-oauth"
+                   (url-http-oauth-url-string url)))
           (let* ((response-url
                   (read-from-minibuffer
                    (format "Browse to %s and paste the redirected code URL: "
                            (concat (nth 0 url-list)
                                    "?"
-                                   (mm-url-encode-www-form-urlencoded
-                                    (list (cons "client_id" (nth 2 url-list))
-                                          (cons "response_type" "code")
-                                          ;; FIXME: Add :expiry support to
-                                          ;; auth-source?
-                                          (cons "scope" (nth 3 url-list))))))))
-                 (code (url-http-oauth-extract-authorization-code 
response-url)))
-            (let ((bearer-got (url-http-oauth-get-access-token url code)))
+                                   (url-build-query-string
+                                    (list (list "client_id" (nth 2 url-list))
+                                          (list "response_type" "code")
+                                          (list "scope" scope)))))))
+                 (code
+                  (url-http-oauth-extract-authorization-code response-url)))
+            (let* ((grant (url-http-oauth-get-access-token-grant url code))
+                   (bearer-retrieved (gethash "access_token" grant))
+                   (auth-result (let ((auth-source-do-cache nil))
+                                  (auth-source-search
+                                   :user (url-user url)
+                                   :host (url-host url)
+                                   :port (url-http-oauth-port url)
+                                   :path path
+                                   :scope (if (string= (gethash "scope" grant)
+                                                       scope)
+                                              scope
+                                            (error
+                                             (concat "url-http-oauth:"
+                                                     " Returned scope did not"
+                                                     " match requested 
scope")))
+                                   :expiry (url-http-oauth-expiry-string grant)
+                                   :secret bearer-retrieved
+                                   :create '(path scope expiry)
+                                   :max 1)))
+                   (save-function (plist-get (car auth-result) 
:save-function)))
               ;; Success, so save bearer.
-              (message "BEARER GOT: %s" bearer-got)
-              (let* ((auth-result (auth-source-search
-                                   :host key-url
-                                   ;; FIXME: Maybe support multiple
-                                   ;; different :user values?
-                                   :user user-login-name
-                                   :secret bearer-got
-                                   :create t))
-                     (save-function (plist-get (car auth-result)
-                                               :save-function)))
-                (if (functionp save-function)
-                    (funcall save-function)
-                  (warn "Saving bearer for %s failed" key-url)))
-              bearer-got))))))
+              (when (functionp save-function)
+                (funcall save-function))
+              bearer-retrieved))))))
 
 ;;; Public function called by `url-get-authentication'.
 ;;;###autoload
 (defun url-oauth-auth (url &optional _prompt _overwrite _realm _args)
   "Return an OAuth 2.0 HTTP authorization header.
-URL is an object representing a parsed URL."
-  ;; Do nothing for now.
+URL is an object representing a parsed URL.  It should specify a
+user, and contain a \"scope\" query argument representing the
+permissions that the caller is requesting."
   (when (url-http-oauth-configuration url)
     (let ((bearer (url-http-oauth-get-bearer url)))
-      (message "BEARER: %s" bearer)
       (concat "Bearer " bearer))))
 
 ;;; Register `url-oauth-auth' HTTP authentication method.