X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/0235128c15aabd21b37e7a359b4932709471f156..73b0cd50031a714347109169ceb8bacae338612a:/lisp/net/secrets.el diff --git a/lisp/net/secrets.el b/lisp/net/secrets.el index c45f6fbb27..89378497c3 100644 --- a/lisp/net/secrets.el +++ b/lisp/net/secrets.el @@ -1,6 +1,6 @@ ;;; secrets.el --- Client interface to gnome-keyring and kwallet. -;; Copyright (C) 2010 Free Software Foundation, Inc. +;; Copyright (C) 2010-2011 Free Software Foundation, Inc. ;; Author: Michael Albinus ;; Keywords: comm password passphrase @@ -129,6 +129,9 @@ ;; (secrets-search-items "session" :user "joe") ;; => ("my item" "another item") +;; Interactively, collections, items and their attributes could be +;; inspected by the command `secrets-show-secrets'. + ;;; Code: ;; It has been tested with GNOME Keyring 2.29.92. An implementation @@ -148,6 +151,13 @@ (require 'dbus) +(autoload 'tree-widget-set-theme "tree-widget") +(autoload 'widget-create-child-and-convert "wid-edit") +(autoload 'widget-default-value-set "wid-edit") +(autoload 'widget-field-end "wid-edit") +(autoload 'widget-member "wid-edit") +(defvar tree-widget-after-toggle-functions) + (defvar secrets-enabled nil "Whether there is a daemon offering the Secret Service API.") @@ -438,10 +448,9 @@ If there is no such COLLECTION, return nil." ;; Check the collections. (catch 'collection-found (dolist (collection-path (secrets-get-collections) nil) - (when - (string-equal - collection - (secrets-get-collection-property collection-path "Label")) + (when (string-equal + collection + (secrets-get-collection-property collection-path "Label")) (throw 'collection-found collection-path)))))) (defun secrets-create-collection (collection) @@ -480,6 +489,13 @@ For the time being, only the alias \"default\" is supported." secrets-interface-service "SetAlias" alias :object-path collection-path)))) +(defun secrets-delete-alias (alias) + "Delete ALIAS, referencing to a collection." + (dbus-call-method + :session secrets-service secrets-path + secrets-interface-service "SetAlias" + alias :object-path secrets-empty-path)) + (defun secrets-unlock-collection (collection) "Unlock collection labelled COLLECTION. If successful, return the object path of the collection." @@ -553,7 +569,7 @@ The object paths of the found items are returned as list." (setq props (add-to-list 'props (list :dict-entry - (symbol-name (car attributes)) + (substring (symbol-name (car attributes)) 1) (cadr attributes)) 'append) attributes (cddr attributes))) @@ -591,7 +607,7 @@ The object path of the created item is returned." (setq props (add-to-list 'props (list :dict-entry - (symbol-name (car attributes)) + (substring (symbol-name (car attributes)) 1) (cadr attributes)) 'append) attributes (cddr attributes))) @@ -646,7 +662,8 @@ If there is no such item, or the item has no attributes, return nil." (let ((item-path (secrets-item-path collection item))) (unless (secrets-empty-path item-path) (mapcar - (lambda (attribute) (cons (intern (car attribute)) (cadr attribute))) + (lambda (attribute) + (cons (intern (concat ":" (car attribute))) (cadr attribute))) (dbus-get-property :session secrets-service item-path secrets-interface-item "Attributes"))))) @@ -665,6 +682,150 @@ If there is no such item, or the item doesn't own this attribute, return nil." :session secrets-service item-path secrets-interface-item "Delete"))))) +;;; Visualization. + +(define-derived-mode secrets-mode nil "Secrets" + "Major mode for presenting password entries retrieved by Security Service. +In this mode, widgets represent the search results. + +\\{secrets-mode-map}" + ;; Keymap. + (setq secrets-mode-map (copy-keymap special-mode-map)) + (set-keymap-parent secrets-mode-map widget-keymap) + (define-key secrets-mode-map "z" 'kill-this-buffer) + + ;; When we toggle, we must set temporary widgets. + (set (make-local-variable 'tree-widget-after-toggle-functions) + '(secrets-tree-widget-after-toggle-function)) + + (when (not (called-interactively-p 'interactive)) + ;; Initialize buffer. + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (erase-buffer)))) + +;; It doesn't make sense to call it interactively. +(put 'secrets-mode 'disabled t) + +;; The very first buffer created with `secrets-mode' does not have the +;; keymap etc. So we create a dummy buffer. Stupid. +(with-temp-buffer (secrets-mode)) + +;; We autoload `secrets-show-secrets' only on systems with D-Bus support. +;;;###autoload(when (featurep 'dbusbind) +;;;###autoload (autoload 'secrets-show-secrets "secrets" nil t)) + +(defun secrets-show-secrets () + "Display a list of collections from the Secret Service API. +The collections are in tree view, that means they can be expanded +to the corresponding secret items, which could also be expanded +to their attributes." + (interactive) + + ;; Check, whether the Secret Service API is enabled. + (if (null secrets-enabled) + (message "Secret Service not available") + + ;; Create the search buffer. + (with-current-buffer (get-buffer-create "*Secrets*") + (switch-to-buffer-other-window (current-buffer)) + ;; Inialize buffer with `secrets-mode'. + (secrets-mode) + (secrets-show-collections)))) + +(defun secrets-show-collections () + "Show all available collections." + (let ((inhibit-read-only t) + (alias (secrets-get-alias "default"))) + (erase-buffer) + (tree-widget-set-theme "folder") + (dolist (coll (secrets-list-collections)) + (widget-create + `(tree-widget + :tag ,coll + :collection ,coll + :open nil + :sample-face bold + :expander secrets-expand-collection))))) + +(defun secrets-expand-collection (widget) + "Expand items of collection shown as WIDGET." + (let ((coll (widget-get widget :collection))) + (mapcar + (lambda (item) + `(tree-widget + :tag ,item + :collection ,coll + :item ,item + :open nil + :sample-face bold + :expander secrets-expand-item)) + (secrets-list-items coll)))) + +(defun secrets-expand-item (widget) + "Expand password and attributes of item shown as WIDGET." + (let* ((coll (widget-get widget :collection)) + (item (widget-get widget :item)) + (attributes (secrets-get-attributes coll item)) + ;; padding is needed to format attribute names. + (padding + (apply + 'max + (cons + (1+ (length "password")) + (mapcar + ;; Atribute names have a leading ":", which will be suppressed. + (lambda (attribute) (length (symbol-name (car attribute)))) + attributes))))) + (cons + ;; The password widget. + `(editable-field :tag "password" + :secret ?* + :value ,(secrets-get-secret coll item) + :sample-face widget-button-pressed + ;; We specify :size in order to limit the field. + :size 0 + :format ,(concat + "%{%t%}:" + (make-string (- padding (length "password")) ? ) + "%v\n")) + (mapcar + (lambda (attribute) + (let ((name (substring (symbol-name (car attribute)) 1)) + (value (cdr attribute))) + ;; The attribute widget. + `(editable-field :tag ,name + :value ,value + :sample-face widget-documentation + ;; We specify :size in order to limit the field. + :size 0 + :format ,(concat + "%{%t%}:" + (make-string (- padding (length name)) ? ) + "%v\n")))) + attributes)))) + +(defun secrets-tree-widget-after-toggle-function (widget &rest ignore) + "Add a temporary widget to show the password." + (dolist (child (widget-get widget :children)) + (when (widget-member child :secret) + (goto-char (widget-field-end child)) + (widget-insert " ") + (widget-create-child-and-convert + child 'push-button + :notify 'secrets-tree-widget-show-password + "Show password"))) + (widget-setup)) + +(defun secrets-tree-widget-show-password (widget &rest ignore) + "Show password, and remove temporary widget." + (let ((parent (widget-get widget :parent))) + (widget-put parent :secret nil) + (widget-default-value-set parent (widget-get parent :value)) + (widget-setup))) + +;;; Initialization. + (when (dbus-ping :session secrets-service 100) ;; We must reset all variables, when there is a new instance of the