[Emacs-diffs] master 1f31c13: Fix Bug#30246

[Michael Albinus]

branch: master
commit 1f31c1348c4ddec31664e78f8cf4b9514d2a32c6
Author: Michael Albinus <address@hidden>
Commit: Michael Albinus <address@hidden>

    Fix Bug#30246
    
    * lisp/auth-source.el (auth-source-secrets-search): Do not
    suppress creation.
    (auth-source-secrets-create): Implement it.  (Bug#30246)
    
    * lisp/net/secrets.el (secrets-debug): Set default to nil.
    
    * test/lisp/auth-source-tests.el (secrets): Require it.
    (auth-source-test-secrets-create-secret): New test.
---
 lisp/auth-source.el            | 167 +++++++++++++++++++++++++++++++++++++++--
 lisp/net/secrets.el            |   2 +-
 test/lisp/auth-source-tests.el |  34 ++++++++-
 3 files changed, 192 insertions(+), 11 deletions(-)

diff --git a/lisp/auth-source.el b/lisp/auth-source.el
index 355c11f..a2ed47a 100644
--- a/lisp/auth-source.el
+++ b/lisp/auth-source.el
@@ -1514,9 +1514,6 @@ authentication tokens:
 "
 
   ;; TODO
-  (cl-assert (not create) nil
-             "The Secrets API auth-source backend doesn't support creation 
yet")
-  ;; TODO
   ;; (secrets-delete-item coll elt)
   (cl-assert (not delete) nil
              "The Secrets API auth-source backend doesn't support deletion 
yet")
@@ -1576,12 +1573,168 @@ authentication tokens:
                                           returned-keys))
                            plist))
                         items)))
+    (cond
+     ;; if we need to create an entry AND none were found to match
+     ((and create
+           (not items))
+
+      ;; create based on the spec and record the value
+      (setq items (or
+                   ;; if the user did not want to create the entry
+                   ;; in the file, it will be returned
+                   (apply (slot-value backend 'create-function) spec)
+                   ;; if not, we do the search again without :create
+                   ;; to get the updated data.
+
+                   ;; the result will be returned, even if the search fails
+                   (apply #'auth-source-secrets-search
+                          (plist-put spec :create nil))))))
     items))
 
-(defun auth-source-secrets-create (&rest spec)
-  ;; TODO
-  ;; (apply 'secrets-create-item (auth-get-source entry) name passwd spec)
-  (debug spec))
+(cl-defun auth-source-secrets-create (&rest spec
+                                      &key backend host port create
+                                      &allow-other-keys)
+  (let* ((base-required '(host user port secret label))
+         ;; we know (because of an assertion in auth-source-search) that the
+         ;; :create parameter is either t or a list (which includes nil)
+         (create-extra (if (eq t create) nil create))
+         (current-data (car (auth-source-search :max 1
+                                                :host host
+                                                :port port)))
+         (required (append base-required create-extra))
+         (collection (oref backend source))
+         ;; `args' are the arguments for `secrets-create-item'.
+         args
+         ;; `valist' is an alist
+         valist
+         ;; `artificial' will be returned if no creation is needed
+         artificial)
+
+    ;; only for base required elements (defined as function parameters):
+    ;; fill in the valist with whatever data we may have from the search
+    ;; we complete the first value if it's a list and use the value otherwise
+    (dolist (br base-required)
+      (let ((val (plist-get spec (auth-source--symbol-keyword br))))
+        (when val
+          (let ((br-choice (cond
+                            ;; all-accepting choice (predicate is t)
+                            ((eq t val) nil)
+                            ;; just the value otherwise
+                            (t val))))
+            (when br-choice
+              (auth-source--aput valist br br-choice))))))
+
+    ;; for extra required elements, see if the spec includes a value for them
+    (dolist (er create-extra)
+      (let ((k (auth-source--symbol-keyword er))
+            (keys (cl-loop for i below (length spec) by 2
+                           collect (nth i spec))))
+        (when (memq k keys)
+          (auth-source--aput valist er (plist-get spec k)))))
+
+    ;; for each required element
+    (dolist (r required)
+      (let* ((data (auth-source--aget valist r))
+             ;; take the first element if the data is a list
+             (data (or (auth-source-netrc-element-or-first data)
+                       (plist-get current-data
+                                  (auth-source--symbol-keyword r))))
+             ;; this is the default to be offered
+             (given-default (auth-source--aget
+                             auth-source-creation-defaults r))
+             ;; the default supplementals are simple:
+             ;; for the user, try `given-default' and then (user-login-name);
+             ;; for the label, try `given-default' and then address@hidden;
+             ;; otherwise take `given-default'
+             (default (cond
+                       ((and (not given-default) (eq r 'user))
+                        (user-login-name))
+                       ((and (not given-default) (eq r 'label))
+                        (format "address@hidden"
+                                (or (auth-source-netrc-element-or-first
+                                     (auth-source--aget valist 'user))
+                                    (plist-get artificial :user))
+                                (or (auth-source-netrc-element-or-first
+                                     (auth-source--aget valist 'host))
+                                    (plist-get artificial :host))))
+                       (t given-default)))
+             (printable-defaults (list
+                                  (cons 'user
+                                        (or
+                                         (auth-source-netrc-element-or-first
+                                          (auth-source--aget valist 'user))
+                                         (plist-get artificial :user)
+                                         "[any user]"))
+                                  (cons 'host
+                                        (or
+                                         (auth-source-netrc-element-or-first
+                                          (auth-source--aget valist 'host))
+                                         (plist-get artificial :host)
+                                         "[any host]"))
+                                  (cons 'port
+                                        (or
+                                         (auth-source-netrc-element-or-first
+                                          (auth-source--aget valist 'port))
+                                         (plist-get artificial :port)
+                                         "[any port]"))
+                                  (cons 'label
+                                        (or
+                                         (auth-source-netrc-element-or-first
+                                          (auth-source--aget valist 'label))
+                                         (plist-get artificial :label)
+                                         "[any label]"))))
+             (prompt (or (auth-source--aget auth-source-creation-prompts r)
+                         (cl-case r
+                           (secret "%p password for address@hidden: ")
+                           (user "%p user name for %h: ")
+                           (host "%p host name for user %u: ")
+                           (port "%p port for address@hidden: ")
+                           (label "Enter label for address@hidden: "))
+                         (format "Enter %s (address@hidden:%%p): " r)))
+             (prompt (auth-source-format-prompt
+                      prompt
+                      `((?u ,(auth-source--aget printable-defaults 'user))
+                        (?h ,(auth-source--aget printable-defaults 'host))
+                        (?p ,(auth-source--aget printable-defaults 'port))))))
+
+        ;; Store the data, prompting for the password if needed.
+        (setq data (or data
+                       (if (eq r 'secret)
+                           (or (eval default) (read-passwd prompt))
+                         (if (stringp default)
+                             (read-string (if (string-match ": *\\'" prompt)
+                                              (concat (substring prompt 0 
(match-beginning 0))
+                                                      " (default " default "): 
")
+                                            (concat prompt "(default " default 
") "))
+                                          nil nil default)
+                           (eval default)))))
+
+        (when data
+          (setq artificial (plist-put artificial
+                                      (auth-source--symbol-keyword r)
+                                      (if (eq r 'secret)
+                                          (let ((data data))
+                                            (lambda () data))
+                                        data))))
+
+        ;; When r is not an empty string...
+        (when (and (stringp data)
+                   (< 0 (length data))
+                   (not (member r '(secret label))))
+          ;; append the key (the symbol name of r)
+          ;; and the value in r
+          (setq args (append args (list (auth-source--symbol-keyword r) 
data))))))
+
+    (plist-put
+     artificial
+     :save-function
+     (let* ((collection collection)
+            (item (plist-get artificial :label))
+            (secret (plist-get artificial :secret))
+            (secret (if (functionp secret) (funcall secret) secret)))
+       (lambda () (apply 'secrets-create-item collection item secret args))))
+
+    (list artificial)))
 
 ;;; Backend specific parsing: Mac OS Keychain (using /usr/bin/security) backend
 
diff --git a/lisp/net/secrets.el b/lisp/net/secrets.el
index e5ab5b3..8070ccf 100644
--- a/lisp/net/secrets.el
+++ b/lisp/net/secrets.el
@@ -158,7 +158,7 @@
 (defvar secrets-enabled nil
   "Whether there is a daemon offering the Secret Service API.")
 
-(defvar secrets-debug t
+(defvar secrets-debug nil
   "Write debug messages")
 
 (defconst secrets-service "org.freedesktop.secrets"
diff --git a/test/lisp/auth-source-tests.el b/test/lisp/auth-source-tests.el
index eb93f74..2f5a932 100644
--- a/test/lisp/auth-source-tests.el
+++ b/test/lisp/auth-source-tests.el
@@ -29,9 +29,7 @@
 (require 'ert)
 (require 'cl-lib)
 (require 'auth-source)
-
-(defvar secrets-enabled t
-  "Enable the secrets backend to test its features.")
+(require 'secrets)
 
 (defun auth-source-ensure-ignored-backend (source)
     (auth-source-validate-backend source '((:source . "")
@@ -289,5 +287,35 @@
         (should (equal found-as-string (concat testname ": " needed)))))
     (delete-file netrc-file)))
 
+(ert-deftest auth-source-test-secrets-create-secret ()
+  (skip-unless secrets-enabled)
+  ;; The "session" collection is temporary for the lifetime of the
+  ;; Emacs process.  Therefore, we don't care to delete it.
+  (let ((auth-sources '((:source (:secrets "session"))))
+        (host (md5 (concat (prin1-to-string process-environment)
+                          (current-time-string))))
+        (passwd (md5 (concat (prin1-to-string process-environment)
+                            (current-time-string) (current-time-string))))
+        auth-info auth-passwd)
+    ;; Redefine `read-*' in order to avoid interactive input.
+    (cl-letf (((symbol-function 'read-passwd) (lambda (_) passwd))
+              ((symbol-function 'read-string)
+               (lambda (_prompt _initial _history default) default)))
+      (setq auth-info
+            (car (auth-source-search
+                  :max 1 :host host :require '(:user :secret) :create t))))
+    (should (functionp (plist-get auth-info :save-function)))
+    (funcall (plist-get auth-info :save-function))
+
+    ;; Check, that the item has been created indeed.
+    (auth-source-forget+ :host t)
+    (setq auth-info (car (auth-source-search :host host))
+         auth-passwd (plist-get auth-info :secret)
+         auth-passwd (if (functionp auth-passwd)
+                         (funcall auth-passwd)
+                       auth-passwd))
+    (should (string-equal (plist-get auth-info :user) (user-login-name)))
+    (should (string-equal auth-passwd passwd))))
+
 (provide 'auth-source-tests)
 ;;; auth-source-tests.el ends here