(require 'mm-util)
(require 'gnus-util)
(require 'assoc)
+
(eval-when-compile (require 'cl))
(eval-and-compile
(or (ignore-errors (require 'eieio))
(autoload 'rfc2104-hash "rfc2104")
+(autoload 'plstore-open "plstore")
+(autoload 'plstore-find "plstore")
+(autoload 'plstore-put "plstore")
+(autoload 'plstore-save "plstore")
+(autoload 'plstore-get-file "plstore")
+
+(autoload 'epa-passphrase-callback-function "epa")
+
+(autoload 'epg-context-operation "epg")
+(autoload 'epg-make-context "epg")
+(autoload 'epg-context-set-passphrase-callback "epg")
+(autoload 'epg-decrypt-string "epg")
+(autoload 'epg-context-set-armor "epg")
+(autoload 'epg-encrypt-string "epg")
+
(defvar secrets-enabled)
(defgroup auth-source nil
:type t
:custom string
:documentation "The backend protocol.")
+ (data :initarg :arg
+ :initform nil
+ :documentation "Internal backend data.")
(create-function :initarg :create-function
:initform ignore
:type function
(const :tag "Never save" nil)
(const :tag "Ask" ask)))
+;; TODO: make the default (setq auth-source-netrc-use-gpg-tokens `((,(if (boundp 'epa-file-auto-mode-alist-entry) (car (symbol-value 'epa-file-auto-mode-alist-entry)) "\\.gpg\\'") never) (t gpg)))
+;; TODO: or maybe leave as (setq auth-source-netrc-use-gpg-tokens 'never)
+
+(defcustom auth-source-netrc-use-gpg-tokens 'never
+ "Set this to tell auth-source when to create GPG password
+tokens in netrc files. It's either an alist or `never'.
+Note that if EPA/EPG is not available, this should NOT be used."
+ :group 'auth-source
+ :version "23.2" ;; No Gnus
+ :type `(choice
+ (const :tag "Always use GPG password tokens" (t gpg))
+ (const :tag "Never use GPG password tokens" never)
+ (repeat :tag "Use a lookup list"
+ (list
+ (choice :tag "Matcher"
+ (const :tag "Match anything" t)
+ (const :tag "The EPA encrypted file extensions"
+ ,(if (boundp 'epa-file-auto-mode-alist-entry)
+ (car (symbol-value
+ 'epa-file-auto-mode-alist-entry))
+ "\\.gpg\\'"))
+ (regexp :tag "Regular expression"))
+ (choice :tag "What to do"
+ (const :tag "Save GPG-encrypted password tokens" gpg)
+ (const :tag "Don't encrypt tokens" never))))))
+
(defvar auth-source-magic "auth-source-magic ")
(defcustom auth-source-do-cache t
(function :tag "Function that takes arguments like `message'")
(const :tag "Don't log anything" nil)))
-(defcustom auth-sources '("~/.authinfo.gpg" "~/.authinfo" "~/.netrc")
+(defcustom auth-sources '("~/.authinfo" "~/.authinfo.gpg" "~/.netrc")
"List of authentication sources.
The default will get login and password information from
,@auth-source-protocols-customize))
(list :tag "User" :inline t
(const :format "" :value :user)
- (choice :tag "Personality/Username"
+ (choice
+ :tag "Personality/Username"
(const :tag "Any" t)
- (string :tag "Name")))))))))
+ (string
+ :tag "Name")))))))))
(defcustom auth-source-gpg-encrypt-to t
"List of recipient keys that `authinfo.gpg' encrypted to.
;; a file name with parameters
((stringp (plist-get entry :source))
- (auth-source-backend
- (plist-get entry :source)
- :source (plist-get entry :source)
- :type 'netrc
- :search-function 'auth-source-netrc-search
- :create-function 'auth-source-netrc-create))
+ (if (equal (file-name-extension (plist-get entry :source)) "plist")
+ (auth-source-backend
+ (plist-get entry :source)
+ :source (plist-get entry :source)
+ :type 'plstore
+ :search-function 'auth-source-plstore-search
+ :create-function 'auth-source-plstore-create
+ :data (plstore-open (plist-get entry :source)))
+ (auth-source-backend
+ (plist-get entry :source)
+ :source (plist-get entry :source)
+ :type 'netrc
+ :search-function 'auth-source-netrc-search
+ :create-function 'auth-source-netrc-create)))
;; the Secrets API. We require the package, in order to have a
;; defined value for `secrets-enabled'.
(equal collection value)
(member value collection)))
+(defvar auth-source-netrc-cache nil)
+
(defun auth-source-forget-all-cached ()
"Forget all cached auth-source data."
(interactive)
when (string-match (concat "^" auth-source-magic)
(symbol-name sym))
;; remove that key
- do (password-cache-remove (symbol-name sym))))
+ do (password-cache-remove (symbol-name sym)))
+ (setq auth-source-netrc-cache nil))
(defun auth-source-remember (spec found)
"Remember FOUND search results for SPEC."
;;; Backend specific parsing: netrc/authinfo backend
-(defvar auth-source-netrc-cache nil)
-
;;; (auth-source-netrc-parse "~/.authinfo.gpg")
(defun* auth-source-netrc-parse (&rest
spec
(null require)
;; every element of require is in the normalized list
(let ((normalized (nth 0 (auth-source-netrc-normalize
- (list alist)))))
+ (list alist) file))))
(loop for req in require
always (plist-get normalized req)))))
(decf max)
(nreverse result))))))
-(defun auth-source-netrc-normalize (alist)
+(defvar auth-source-passphrase-alist nil)
+
+(defun auth-source-passphrase-callback-function (context key-id handback
+ &optional sym-detail)
+ "Exactly like `epa-passphrase-callback-function' but takes an
+extra SYM-DETAIL parameter which will be printed at the end of
+the symmetric passphrase prompt, and assumes symmetric
+encryption."
+ (read-passwd
+ (format "Passphrase for symmetric encryption%s%s: "
+ ;; Add the file name to the prompt, if any.
+ (if (stringp handback)
+ (format " for %s" handback)
+ "")
+ (if (stringp sym-detail)
+ sym-detail
+ ""))
+ (eq (epg-context-operation context) 'encrypt)))
+
+(defun auth-source-token-passphrase-callback-function (context key-id file)
+ (if (eq key-id 'SYM)
+ (let* ((file (file-truename file))
+ (entry (assoc file auth-source-passphrase-alist))
+ passphrase)
+ ;; return the saved passphrase, calling a function if needed
+ (or (copy-sequence (if (functionp (cdr entry))
+ (funcall (cdr entry))
+ (cdr entry)))
+ (progn
+ (unless entry
+ (setq entry (list file))
+ (push entry auth-source-passphrase-alist))
+ (setq passphrase (auth-source-passphrase-callback-function context
+ key-id
+ file
+ " tokens"))
+ (setcdr entry (lexical-let ((p (copy-sequence passphrase)))
+ (lambda () p)))
+ passphrase)))
+ (epa-passphrase-callback-function context key-id file)))
+
+;; (auth-source-epa-extract-gpg-token "gpg:LS0tLS1CRUdJTiBQR1AgTUVTU0FHRS0tLS0tClZlcnNpb246IEdudVBHIHYxLjQuMTEgKEdOVS9MaW51eCkKCmpBMEVBd01DT25qMjB1ak9rZnRneVI3K21iNm9aZWhuLzRad3cySkdlbnVaKzRpeEswWDY5di9icDI1U1dsQT0KPS9yc2wKLS0tLS1FTkQgUEdQIE1FU1NBR0UtLS0tLQo=" "~/.netrc")
+(defun auth-source-epa-extract-gpg-token (secret file)
+ "Pass either the decoded SECRET or the gpg:BASE64DATA version.
+FILE is the file from which we obtained this token."
+ (when (string-match "^gpg:\\(.+\\)" secret)
+ (setq secret (base64-decode-string (match-string 1 secret))))
+ (let ((context (epg-make-context 'OpenPGP))
+ plain)
+ (epg-context-set-passphrase-callback
+ context
+ (cons #'auth-source-token-passphrase-callback-function
+ file))
+ (epg-decrypt-string context secret)))
+
+;; (insert (auth-source-epa-make-gpg-token "mysecret" "~/.netrc"))
+(defun auth-source-epa-make-gpg-token (secret file)
+ (let ((context (epg-make-context 'OpenPGP))
+ (pp-escape-newlines nil)
+ cipher)
+ (epg-context-set-armor context t)
+ (epg-context-set-passphrase-callback
+ context
+ (cons #'auth-source-token-passphrase-callback-function
+ file))
+ (setq cipher (epg-encrypt-string context secret nil))
+ (with-temp-buffer
+ (insert cipher)
+ (base64-encode-region (point-min) (point-max) t)
+ (concat "gpg:" (buffer-substring-no-properties
+ (point-min)
+ (point-max))))))
+
+(defun auth-source-netrc-normalize (alist filename)
(mapcar (lambda (entry)
(let (ret item)
(while (setq item (pop entry))
;; send back the secret in a function (lexical binding)
(when (equal k "secret")
- (setq v (lexical-let ((v v))
- (lambda () v))))
-
- (setq ret (plist-put ret
- (intern (concat ":" k))
- v))
- ))
- ret))
- alist))
+ (setq v (lexical-let ((lexv v)
+ (token-decoder nil))
+ (when (string-match "^gpg:" lexv)
+ ;; it's a GPG token: create a token decoder
+ ;; which unsets itself once
+ (setq token-decoder
+ (lambda (val)
+ (prog1
+ (auth-source-epa-extract-gpg-token
+ val
+ filename)
+ (setq token-decoder nil)))))
+ (lambda ()
+ (when token-decoder
+ (setq lexv (funcall token-decoder lexv)))
+ lexv))))
+ (setq ret (plist-put ret
+ (intern (concat ":" k))
+ v))))
+ ret))
+ alist))
;;; (setq secret (plist-get (nth 0 (auth-source-search :host t :type 'netrc :K 1 :max 1)) :secret))
;;; (funcall secret)
:file (oref backend source)
:host (or host t)
:user (or user t)
- :port (or port t)))))
+ :port (or port t))
+ (oref backend source))))
;; if we need to create an entry AND none were found to match
(when (and create
;; 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))
(file (oref backend source))
(add "")
(dolist (r required)
(let* ((data (aget valist r))
;; take the first element if the data is a list
- (data (auth-source-netrc-element-or-first data))
+ (data (or (auth-source-netrc-element-or-first data)
+ (plist-get current-data
+ (intern (format ":%s" r) obarray))))
;; this is the default to be offered
(given-default (aget auth-source-creation-defaults r))
;; the default supplementals are simple:
(cond
((and (null data) (eq r 'secret))
;; Special case prompt for passwords.
- (read-passwd prompt))
+;; TODO: make the default (setq auth-source-netrc-use-gpg-tokens `((,(if (boundp 'epa-file-auto-mode-alist-entry) (car (symbol-value 'epa-file-auto-mode-alist-entry)) "\\.gpg\\'") nil) (t gpg)))
+;; TODO: or maybe leave as (setq auth-source-netrc-use-gpg-tokens 'never)
+ (let* ((ep (format "Use GPG password tokens in %s?" file))
+ (gpg-encrypt
+ (cond
+ ((eq auth-source-netrc-use-gpg-tokens 'never)
+ 'never)
+ ((listp auth-source-netrc-use-gpg-tokens)
+ (let ((check (copy-sequence
+ auth-source-netrc-use-gpg-tokens))
+ item ret)
+ (while check
+ (setq item (pop check))
+ (when (or (eq (car item) t)
+ (string-match (car item) file))
+ (setq ret (cdr item))
+ (setq check nil)))))
+ (t 'never)))
+ (plain (read-passwd prompt)))
+ ;; ask if we don't know what to do (in which case
+ ;; auth-source-netrc-use-gpg-tokens must be a list)
+ (unless gpg-encrypt
+ (setq gpg-encrypt (if (y-or-n-p ep) 'gpg 'never))
+ ;; TODO: save the defcustom now? or ask?
+ (setq auth-source-netrc-use-gpg-tokens
+ (cons `(,file ,gpg-encrypt)
+ auth-source-netrc-use-gpg-tokens)))
+ (if (eq gpg-encrypt 'gpg)
+ (auth-source-epa-make-gpg-token plain file)
+ plain)))
((null data)
(when default
(setq prompt
(let ((printer (lambda ()
;; append the key (the symbol name of r)
;; and the value in r
- (format "%s%s %S"
+ (format "%s%s %s"
;; prepend a space
(if (zerop (length add)) "" " ")
;; remap auth-source tokens to netrc
(case r
- ('user "login")
- ('host "machine")
- ('secret "password")
- ('port "port") ; redundant but clearer
+ (user "login")
+ (host "machine")
+ (secret "password")
+ (port "port") ; redundant but clearer
(t (symbol-name r)))
- ;; the value will be printed in %S format
- data))))
+ (if (string-match "[\" ]" data)
+ (format "%S" data)
+ data)))))
(setq add (concat add (funcall printer)))))))
(plist-put
(help-mode))))
(?n (setq add ""
done t))
- (?N (setq add ""
- done t
- auth-source-save-behavior nil))
+ (?N
+ (setq add ""
+ done t)
+ (customize-save-variable 'auth-source-save-behavior nil))
(?e (setq add (read-string "Line to add: " add)))
(t nil)))
;; (apply 'secrets-create-item (auth-get-source entry) name passwd spec)
(debug spec))
+;;; Backend specific parsing: PLSTORE backend
+
+(defun* auth-source-plstore-search (&rest
+ spec
+ &key backend create delete label
+ type max host user port
+ &allow-other-keys)
+ "Search the PLSTORE; spec is like `auth-source'."
+
+ ;; TODO
+ (assert (not delete) nil
+ "The PLSTORE auth-source backend doesn't support deletion yet")
+
+ (let* ((store (oref backend data))
+ (max (or max 5000)) ; sanity check: default to stop at 5K
+ (ignored-keys '(:create :delete :max :backend :require))
+ (search-keys (loop for i below (length spec) by 2
+ unless (memq (nth i spec) ignored-keys)
+ collect (nth i spec)))
+ ;; build a search spec without the ignored keys
+ ;; if a search key is nil or t (match anything), we skip it
+ (search-spec (apply 'append (mapcar
+ (lambda (k)
+ (let ((v (plist-get spec k)))
+ (if (or (null v)
+ (eq t v))
+ nil
+ (if (stringp v)
+ (setq v (list v)))
+ (list k v))))
+ search-keys)))
+ ;; needed keys (always including host, login, port, and secret)
+ (returned-keys (mm-delete-duplicates (append
+ '(:host :login :port :secret)
+ search-keys)))
+ (items (plstore-find store search-spec))
+ (items (butlast items (- (length items) max)))
+ ;; convert the item to a full plist
+ (items (mapcar (lambda (item)
+ (let* ((plist (copy-tree (cdr item)))
+ (secret (plist-member plist :secret)))
+ (if secret
+ (setcar
+ (cdr secret)
+ (lexical-let ((v (car (cdr secret))))
+ (lambda () v))))
+ plist))
+ items))
+ ;; ensure each item has each key in `returned-keys'
+ (items (mapcar (lambda (plist)
+ (append
+ (apply 'append
+ (mapcar (lambda (req)
+ (if (plist-get plist req)
+ nil
+ (list req nil)))
+ returned-keys))
+ plist))
+ items)))
+ ;; if we need to create an entry AND none were found to match
+ (when (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-plstore-search
+ (plist-put spec :create nil)))))
+ items))
+
+(defun* auth-source-plstore-create (&rest spec
+ &key backend
+ secret host user port create
+ &allow-other-keys)
+ (let* ((base-required '(host user port secret))
+ (base-secret '(secret))
+ ;; 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))
+ (file (oref backend source))
+ (add "")
+ ;; `valist' is an alist
+ valist
+ ;; `artificial' will be returned if no creation is needed
+ artificial
+ secret-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)
+ (when (symbol-value br)
+ (let ((br-choice (cond
+ ;; all-accepting choice (predicate is t)
+ ((eq t (symbol-value br)) nil)
+ ;; just the value otherwise
+ (t (symbol-value br)))))
+ (when br-choice
+ (aput 'valist br br-choice)))))
+
+ ;; for extra required elements, see if the spec includes a value for them
+ (dolist (er create-extra)
+ (let ((name (concat ":" (symbol-name er)))
+ (keys (loop for i below (length spec) by 2
+ collect (nth i spec))))
+ (dolist (k keys)
+ (when (equal (symbol-name k) name)
+ (aput 'valist er (plist-get spec k))))))
+
+ ;; for each required element
+ (dolist (r required)
+ (let* ((data (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
+ (intern (format ":%s" r) obarray))))
+ ;; this is the default to be offered
+ (given-default (aget auth-source-creation-defaults r))
+ ;; the default supplementals are simple:
+ ;; for the user, try `given-default' and then (user-login-name);
+ ;; otherwise take `given-default'
+ (default (cond
+ ((and (not given-default) (eq r 'user))
+ (user-login-name))
+ (t given-default)))
+ (printable-defaults (list
+ (cons 'user
+ (or
+ (auth-source-netrc-element-or-first
+ (aget valist 'user))
+ (plist-get artificial :user)
+ "[any user]"))
+ (cons 'host
+ (or
+ (auth-source-netrc-element-or-first
+ (aget valist 'host))
+ (plist-get artificial :host)
+ "[any host]"))
+ (cons 'port
+ (or
+ (auth-source-netrc-element-or-first
+ (aget valist 'port))
+ (plist-get artificial :port)
+ "[any port]"))))
+ (prompt (or (aget auth-source-creation-prompts r)
+ (case r
+ (secret "%p password for %u@%h: ")
+ (user "%p user name for %h: ")
+ (host "%p host name for user %u: ")
+ (port "%p port for %u@%h: "))
+ (format "Enter %s (%%u@%%h:%%p): " r)))
+ (prompt (auth-source-format-prompt
+ prompt
+ `((?u ,(aget printable-defaults 'user))
+ (?h ,(aget printable-defaults 'host))
+ (?p ,(aget printable-defaults 'port))))))
+
+ ;; Store the data, prompting for the password if needed.
+ (setq data
+ (cond
+ ((and (null data) (eq r 'secret))
+ ;; Special case prompt for passwords.
+ (read-passwd prompt))
+ ((null data)
+ (when default
+ (setq prompt
+ (if (string-match ": *\\'" prompt)
+ (concat (substring prompt 0 (match-beginning 0))
+ " (default " default "): ")
+ (concat prompt "(default " default ") "))))
+ (read-string prompt nil nil default))
+ (t (or data default))))
+
+ (when data
+ (if (member r base-secret)
+ (setq secret-artificial
+ (plist-put secret-artificial
+ (intern (concat ":" (symbol-name r)))
+ data))
+ (setq artificial (plist-put artificial
+ (intern (concat ":" (symbol-name r)))
+ data))))))
+ (plstore-put (oref backend data)
+ (sha1 (format "%s@%s:%s"
+ (plist-get artificial :user)
+ (plist-get artificial :host)
+ (plist-get artificial :port)))
+ artificial secret-artificial)
+ (if (y-or-n-p (format "Save auth info to file %s? "
+ (plstore-get-file (oref backend data))))
+ (plstore-save (oref backend data)))))
+
;;; older API
;;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" t "tzz")