Line data Source code
1 : ;;; auth-source.el --- authentication sources for Gnus and Emacs -*- lexical-binding: t -*-
2 :
3 : ;; Copyright (C) 2008-2017 Free Software Foundation, Inc.
4 :
5 : ;; Author: Ted Zlatanov <tzz@lifelogs.com>
6 : ;; Keywords: news
7 :
8 : ;; This file is part of GNU Emacs.
9 :
10 : ;; GNU Emacs is free software: you can redistribute it and/or modify
11 : ;; it under the terms of the GNU General Public License as published by
12 : ;; the Free Software Foundation, either version 3 of the License, or
13 : ;; (at your option) any later version.
14 :
15 : ;; GNU Emacs is distributed in the hope that it will be useful,
16 : ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 : ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 : ;; GNU General Public License for more details.
19 :
20 : ;; You should have received a copy of the GNU General Public License
21 : ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
22 :
23 : ;;; Commentary:
24 :
25 : ;; This is the auth-source.el package. It lets users tell Gnus how to
26 : ;; authenticate in a single place. Simplicity is the goal. Instead
27 : ;; of providing 5000 options, we'll stick to simple, easy to
28 : ;; understand options.
29 :
30 : ;; See the auth.info Info documentation for details.
31 :
32 : ;; TODO:
33 :
34 : ;; - never decode the backend file unless it's necessary
35 : ;; - a more generic way to match backends and search backend contents
36 : ;; - absorb netrc.el and simplify it
37 : ;; - protect passwords better
38 : ;; - allow creating and changing netrc lines (not files) e.g. change a password
39 :
40 : ;;; Code:
41 :
42 : (require 'password-cache)
43 :
44 : (eval-when-compile (require 'cl-lib))
45 : (require 'eieio)
46 :
47 : (autoload 'secrets-create-item "secrets")
48 : (autoload 'secrets-delete-item "secrets")
49 : (autoload 'secrets-get-alias "secrets")
50 : (autoload 'secrets-get-attributes "secrets")
51 : (autoload 'secrets-get-secret "secrets")
52 : (autoload 'secrets-list-collections "secrets")
53 : (autoload 'secrets-search-items "secrets")
54 :
55 : (autoload 'rfc2104-hash "rfc2104")
56 :
57 : (autoload 'plstore-open "plstore")
58 : (autoload 'plstore-find "plstore")
59 : (autoload 'plstore-put "plstore")
60 : (autoload 'plstore-delete "plstore")
61 : (autoload 'plstore-save "plstore")
62 : (autoload 'plstore-get-file "plstore")
63 :
64 : (eval-when-compile (require 'epg)) ;; setf-method for `epg-context-armor'
65 : (autoload 'epg-make-context "epg")
66 : (autoload 'epg-context-set-passphrase-callback "epg")
67 : (autoload 'epg-decrypt-string "epg")
68 : (autoload 'epg-encrypt-string "epg")
69 :
70 : (autoload 'help-mode "help-mode" nil t)
71 :
72 : (defvar secrets-enabled)
73 :
74 : (defgroup auth-source nil
75 : "Authentication sources."
76 : :version "23.1" ;; No Gnus
77 : :group 'gnus)
78 :
79 : ;;;###autoload
80 : (defcustom auth-source-cache-expiry 7200
81 : "How many seconds passwords are cached, or nil to disable
82 : expiring. Overrides `password-cache-expiry' through a
83 : let-binding."
84 : :version "24.1"
85 : :group 'auth-source
86 : :type '(choice (const :tag "Never" nil)
87 : (const :tag "All Day" 86400)
88 : (const :tag "2 Hours" 7200)
89 : (const :tag "30 Minutes" 1800)
90 : (integer :tag "Seconds")))
91 :
92 : ;; The slots below correspond with the `auth-source-search' spec,
93 : ;; so a backend with :host set, for instance, would match only
94 : ;; searches for that host. Normally they are nil.
95 : (defclass auth-source-backend ()
96 : ((type :initarg :type
97 : :initform 'netrc
98 : :type symbol
99 : :custom symbol
100 : :documentation "The backend type.")
101 : (source :initarg :source
102 : :type string
103 : :custom string
104 : :documentation "The backend source.")
105 : (host :initarg :host
106 : :initform t
107 : :type t
108 : :custom string
109 : :documentation "The backend host.")
110 : (user :initarg :user
111 : :initform t
112 : :type t
113 : :custom string
114 : :documentation "The backend user.")
115 : (port :initarg :port
116 : :initform t
117 : :type t
118 : :custom string
119 : :documentation "The backend protocol.")
120 : (data :initarg :data
121 : :initform nil
122 : :documentation "Internal backend data.")
123 : (create-function :initarg :create-function
124 : :initform ignore
125 : :type function
126 : :custom function
127 : :documentation "The create function.")
128 : (search-function :initarg :search-function
129 : :initform ignore
130 : :type function
131 : :custom function
132 : :documentation "The search function.")))
133 :
134 : (defcustom auth-source-protocols '((imap "imap" "imaps" "143" "993")
135 : (pop3 "pop3" "pop" "pop3s" "110" "995")
136 : (ssh "ssh" "22")
137 : (sftp "sftp" "115")
138 : (smtp "smtp" "25"))
139 : "List of authentication protocols and their names"
140 :
141 : :group 'auth-source
142 : :version "23.2" ;; No Gnus
143 : :type '(repeat :tag "Authentication Protocols"
144 : (cons :tag "Protocol Entry"
145 : (symbol :tag "Protocol")
146 : (repeat :tag "Names"
147 : (string :tag "Name")))))
148 :
149 : ;; Generate all the protocols in a format Customize can use.
150 : ;; TODO: generate on the fly from auth-source-protocols
151 : (defconst auth-source-protocols-customize
152 : (mapcar (lambda (a)
153 : (let ((p (car-safe a)))
154 : (list 'const
155 : :tag (upcase (symbol-name p))
156 : p)))
157 : auth-source-protocols))
158 :
159 : (defvar auth-source-creation-defaults nil
160 : ;; FIXME: AFAICT this is not set (or let-bound) anywhere!
161 : "Defaults for creating token values. Usually let-bound.")
162 :
163 : (defvar auth-source-creation-prompts nil
164 : "Default prompts for token values. Usually let-bound.")
165 :
166 : (make-obsolete 'auth-source-hide-passwords nil "Emacs 24.1")
167 :
168 : (defcustom auth-source-save-behavior 'ask
169 : "If set, auth-source will respect it for save behavior."
170 : :group 'auth-source
171 : :version "23.2" ;; No Gnus
172 : :type `(choice
173 : :tag "auth-source new token save behavior"
174 : (const :tag "Always save" t)
175 : (const :tag "Never save" nil)
176 : (const :tag "Ask" ask)))
177 :
178 : ;; TODO: make the default (setq auth-source-netrc-use-gpg-tokens `((,(if (boundp 'epa-file-auto-mode-alist-entry) (car epa-file-auto-mode-alist-entry) "\\.gpg\\'") never) (t gpg)))
179 : ;; TODO: or maybe leave as (setq auth-source-netrc-use-gpg-tokens 'never)
180 :
181 : (defcustom auth-source-netrc-use-gpg-tokens 'never
182 : "Set this to tell auth-source when to create GPG password
183 : tokens in netrc files. It's either an alist or `never'.
184 : Note that if EPA/EPG is not available, this should NOT be used."
185 : :group 'auth-source
186 : :version "23.2" ;; No Gnus
187 : :type `(choice
188 : (const :tag "Always use GPG password tokens" (t gpg))
189 : (const :tag "Never use GPG password tokens" never)
190 : (repeat :tag "Use a lookup list"
191 : (list
192 : (choice :tag "Matcher"
193 : (const :tag "Match anything" t)
194 : (const :tag "The EPA encrypted file extensions"
195 : ,(if (boundp 'epa-file-auto-mode-alist-entry)
196 : (car epa-file-auto-mode-alist-entry)
197 : "\\.gpg\\'"))
198 : (regexp :tag "Regular expression"))
199 : (choice :tag "What to do"
200 : (const :tag "Save GPG-encrypted password tokens" gpg)
201 : (const :tag "Don't encrypt tokens" never))))))
202 :
203 : (defcustom auth-source-do-cache t
204 : "Whether auth-source should cache information with `password-cache'."
205 : :group 'auth-source
206 : :version "23.2" ;; No Gnus
207 : :type `boolean)
208 :
209 : (defcustom auth-source-debug nil
210 : "Whether auth-source should log debug messages.
211 :
212 : If the value is nil, debug messages are not logged.
213 :
214 : If the value is t, debug messages are logged with `message'. In
215 : that case, your authentication data will be in the clear (except
216 : for passwords).
217 :
218 : If the value is a function, debug messages are logged by calling
219 : that function using the same arguments as `message'."
220 : :group 'auth-source
221 : :version "23.2" ;; No Gnus
222 : :type `(choice
223 : :tag "auth-source debugging mode"
224 : (const :tag "Log using `message' to the *Messages* buffer" t)
225 : (const :tag "Log all trivia with `message' to the *Messages* buffer"
226 : trivia)
227 : (function :tag "Function that takes arguments like `message'")
228 : (const :tag "Don't log anything" nil)))
229 :
230 : (defcustom auth-sources '("~/.authinfo" "~/.authinfo.gpg" "~/.netrc")
231 : "List of authentication sources.
232 : Each entry is the authentication type with optional properties.
233 : Entries are tried in the order in which they appear.
234 : See Info node `(auth)Help for users' for details.
235 :
236 : If an entry names a file with the \".gpg\" extension and you have
237 : EPA/EPG set up, the file will be encrypted and decrypted
238 : automatically. See Info node `(epa)Encrypting/decrypting gpg files'
239 : for details.
240 :
241 : It's best to customize this with `\\[customize-variable]' because the choices
242 : can get pretty complex."
243 : :group 'auth-source
244 : :version "24.1" ;; No Gnus
245 : :type `(repeat :tag "Authentication Sources"
246 : (choice
247 : (string :tag "Just a file")
248 : (const :tag "Default Secrets API Collection" default)
249 : (const :tag "Login Secrets API Collection" "secrets:Login")
250 : (const :tag "Temp Secrets API Collection" "secrets:session")
251 :
252 : (const :tag "Default internet Mac OS Keychain"
253 : macos-keychain-internet)
254 :
255 : (const :tag "Default generic Mac OS Keychain"
256 : macos-keychain-generic)
257 :
258 : (list :tag "Source definition"
259 : (const :format "" :value :source)
260 : (choice :tag "Authentication backend choice"
261 : (string :tag "Authentication Source (file)")
262 : (list
263 : :tag "Secret Service API/KWallet/GNOME Keyring"
264 : (const :format "" :value :secrets)
265 : (choice :tag "Collection to use"
266 : (string :tag "Collection name")
267 : (const :tag "Default" default)
268 : (const :tag "Login" "Login")
269 : (const
270 : :tag "Temporary" "session")))
271 : (list
272 : :tag "Mac OS internet Keychain"
273 : (const :format ""
274 : :value :macos-keychain-internet)
275 : (choice :tag "Collection to use"
276 : (string :tag "internet Keychain path")
277 : (const :tag "default" default)))
278 : (list
279 : :tag "Mac OS generic Keychain"
280 : (const :format ""
281 : :value :macos-keychain-generic)
282 : (choice :tag "Collection to use"
283 : (string :tag "generic Keychain path")
284 : (const :tag "default" default))))
285 : (repeat :tag "Extra Parameters" :inline t
286 : (choice :tag "Extra parameter"
287 : (list
288 : :tag "Host"
289 : (const :format "" :value :host)
290 : (choice :tag "Host (machine) choice"
291 : (const :tag "Any" t)
292 : (regexp
293 : :tag "Regular expression")))
294 : (list
295 : :tag "Protocol"
296 : (const :format "" :value :port)
297 : (choice
298 : :tag "Protocol"
299 : (const :tag "Any" t)
300 : ,@auth-source-protocols-customize))
301 : (list :tag "User" :inline t
302 : (const :format "" :value :user)
303 : (choice
304 : :tag "Personality/Username"
305 : (const :tag "Any" t)
306 : (string
307 : :tag "Name")))))))))
308 :
309 : (defcustom auth-source-gpg-encrypt-to t
310 : "List of recipient keys that `authinfo.gpg' encrypted to.
311 : If the value is not a list, symmetric encryption will be used."
312 : :group 'auth-source
313 : :version "24.1" ;; No Gnus
314 : :type '(choice (const :tag "Symmetric encryption" t)
315 : (repeat :tag "Recipient public keys"
316 : (string :tag "Recipient public key"))))
317 :
318 : (defun auth-source-do-debug (&rest msg)
319 0 : (when auth-source-debug
320 0 : (apply #'auth-source-do-warn msg)))
321 :
322 : (defun auth-source-do-trivia (&rest msg)
323 0 : (when (or (eq auth-source-debug 'trivia)
324 0 : (functionp auth-source-debug))
325 0 : (apply #'auth-source-do-warn msg)))
326 :
327 : (defun auth-source-do-warn (&rest msg)
328 0 : (apply
329 : ;; set logger to either the function in auth-source-debug or 'message
330 : ;; note that it will be 'message if auth-source-debug is nil
331 0 : (if (functionp auth-source-debug)
332 0 : auth-source-debug
333 0 : 'message)
334 0 : msg))
335 :
336 : (defun auth-source-read-char-choice (prompt choices)
337 : "Read one of CHOICES by `read-char-choice', or `read-char'.
338 : `dropdown-list' support is disabled because it doesn't work reliably.
339 : Only one of CHOICES will be returned. The PROMPT is augmented
340 : with \"[a/b/c] \" if CHOICES is \(?a ?b ?c)."
341 0 : (when choices
342 0 : (let* ((prompt-choices
343 0 : (apply #'concat
344 0 : (cl-loop for c in choices collect (format "%c/" c))))
345 0 : (prompt-choices (concat "[" (substring prompt-choices 0 -1) "] "))
346 0 : (full-prompt (concat prompt prompt-choices))
347 : k)
348 :
349 0 : (while (not (memq k choices))
350 0 : (setq k (read-char-choice full-prompt choices)))
351 0 : k)))
352 :
353 : (defvar auth-source-backend-parser-functions nil
354 : "List of auth-source parser functions.
355 : Each function takes an entry from `auth-sources' as parameter and
356 : returns a backend or nil if the entry is not supported. Add a
357 : parser function to this list with `add-hook'. Searching for a
358 : backend starts with the first element on the list and stops as
359 : soon as a function returns non-nil.")
360 :
361 : (defun auth-source-backend-parse (entry)
362 : "Create an auth-source-backend from an ENTRY in `auth-sources'."
363 :
364 0 : (let (backend)
365 0 : (cl-dolist (f auth-source-backend-parser-functions)
366 0 : (when (setq backend (funcall f entry))
367 0 : (cl-return)))
368 :
369 0 : (unless backend
370 : ;; none of the parsers worked
371 0 : (auth-source-do-warn
372 0 : "auth-source-backend-parse: invalid backend spec: %S" entry)
373 0 : (setq backend (make-instance 'auth-source-backend
374 : :source ""
375 0 : :type 'ignore)))
376 0 : (auth-source-backend-parse-parameters entry backend)))
377 :
378 : (defun auth-source-backends-parser-file (entry)
379 : ;; take just a file name use it as a netrc/plist file
380 : ;; matching any user, host, and protocol
381 0 : (when (stringp entry)
382 0 : (setq entry `(:source ,entry)))
383 0 : (cond
384 : ;; a file name with parameters
385 0 : ((stringp (plist-get entry :source))
386 0 : (if (equal (file-name-extension (plist-get entry :source)) "plist")
387 0 : (auth-source-backend
388 0 : (plist-get entry :source)
389 0 : :source (plist-get entry :source)
390 : :type 'plstore
391 0 : :search-function #'auth-source-plstore-search
392 0 : :create-function #'auth-source-plstore-create
393 0 : :data (plstore-open (plist-get entry :source)))
394 0 : (auth-source-backend
395 0 : (plist-get entry :source)
396 0 : :source (plist-get entry :source)
397 : :type 'netrc
398 0 : :search-function #'auth-source-netrc-search
399 0 : :create-function #'auth-source-netrc-create)))))
400 :
401 : ;; Note this function should be last in the parser functions, so we add it first
402 : (add-hook 'auth-source-backend-parser-functions 'auth-source-backends-parser-file)
403 :
404 : (defun auth-source-backends-parser-macos-keychain (entry)
405 : ;; take macos-keychain-{internet,generic}:XYZ and use it as macOS
406 : ;; Keychain "XYZ" matching any user, host, and protocol
407 0 : (when (and (stringp entry) (string-match "^macos-keychain-internet:\\(.+\\)"
408 0 : entry))
409 0 : (setq entry `(:source (:macos-keychain-internet
410 0 : ,(match-string 1 entry)))))
411 0 : (when (and (stringp entry) (string-match "^macos-keychain-generic:\\(.+\\)"
412 0 : entry))
413 0 : (setq entry `(:source (:macos-keychain-generic
414 0 : ,(match-string 1 entry)))))
415 : ;; take 'macos-keychain-internet or generic and use it as a Mac OS
416 : ;; Keychain collection matching any user, host, and protocol
417 0 : (when (eq entry 'macos-keychain-internet)
418 0 : (setq entry '(:source (:macos-keychain-internet default))))
419 0 : (when (eq entry 'macos-keychain-generic)
420 0 : (setq entry '(:source (:macos-keychain-generic default))))
421 0 : (cond
422 : ;; the macOS Keychain
423 0 : ((and
424 0 : (not (null (plist-get entry :source))) ; the source must not be nil
425 0 : (listp (plist-get entry :source)) ; and it must be a list
426 0 : (or
427 0 : (plist-get (plist-get entry :source) :macos-keychain-generic)
428 0 : (plist-get (plist-get entry :source) :macos-keychain-internet)))
429 :
430 0 : (let* ((source-spec (plist-get entry :source))
431 0 : (keychain-generic (plist-get source-spec :macos-keychain-generic))
432 0 : (keychain-type (if keychain-generic
433 : 'macos-keychain-generic
434 0 : 'macos-keychain-internet))
435 0 : (source (plist-get source-spec (if keychain-generic
436 : :macos-keychain-generic
437 0 : :macos-keychain-internet))))
438 :
439 0 : (when (symbolp source)
440 0 : (setq source (symbol-name source)))
441 :
442 0 : (auth-source-backend
443 0 : (format "Mac OS Keychain (%s)" source)
444 0 : :source source
445 0 : :type keychain-type
446 0 : :search-function #'auth-source-macos-keychain-search
447 0 : :create-function #'auth-source-macos-keychain-create)))))
448 :
449 : (add-hook 'auth-source-backend-parser-functions 'auth-source-backends-parser-macos-keychain)
450 :
451 : (defun auth-source-backends-parser-secrets (entry)
452 : ;; take secrets:XYZ and use it as Secrets API collection "XYZ"
453 : ;; matching any user, host, and protocol
454 0 : (when (and (stringp entry) (string-match "^secrets:\\(.+\\)" entry))
455 0 : (setq entry `(:source (:secrets ,(match-string 1 entry)))))
456 : ;; take 'default and use it as a Secrets API default collection
457 : ;; matching any user, host, and protocol
458 0 : (when (eq entry 'default)
459 0 : (setq entry '(:source (:secrets default))))
460 0 : (cond
461 : ;; the Secrets API. We require the package, in order to have a
462 : ;; defined value for `secrets-enabled'.
463 0 : ((and
464 0 : (not (null (plist-get entry :source))) ; the source must not be nil
465 0 : (listp (plist-get entry :source)) ; and it must be a list
466 0 : (not (null (plist-get
467 0 : (plist-get entry :source)
468 0 : :secrets))) ; the source must have :secrets
469 0 : (require 'secrets nil t) ; and we must load the Secrets API
470 0 : secrets-enabled) ; and that API must be enabled
471 :
472 : ;; the source is either the :secrets key in ENTRY or
473 : ;; if that's missing or nil, it's "session"
474 0 : (let ((source (plist-get (plist-get entry :source) :secrets)))
475 :
476 : ;; if the source is a symbol, we look for the alias named so,
477 : ;; and if that alias is missing, we use "Login"
478 0 : (when (symbolp source)
479 0 : (setq source (or (secrets-get-alias (symbol-name source))
480 0 : "Login")))
481 :
482 0 : (if (featurep 'secrets)
483 0 : (auth-source-backend
484 0 : (format "Secrets API (%s)" source)
485 0 : :source source
486 : :type 'secrets
487 0 : :search-function #'auth-source-secrets-search
488 0 : :create-function #'auth-source-secrets-create)
489 0 : (auth-source-do-warn
490 0 : "auth-source-backend-parse: no Secrets API, ignoring spec: %S" entry)
491 0 : (auth-source-backend
492 0 : (format "Ignored Secrets API (%s)" source)
493 : :source ""
494 0 : :type 'ignore))))))
495 :
496 : (add-hook 'auth-source-backend-parser-functions 'auth-source-backends-parser-secrets)
497 :
498 : (defun auth-source-backend-parse-parameters (entry backend)
499 : "Fills in the extra auth-source-backend parameters of ENTRY.
500 : Using the plist ENTRY, get the :host, :port, and :user search
501 : parameters."
502 0 : (let ((entry (if (stringp entry)
503 : nil
504 0 : entry))
505 : val)
506 0 : (when (setq val (plist-get entry :host))
507 0 : (oset backend host val))
508 0 : (when (setq val (plist-get entry :user))
509 0 : (oset backend user val))
510 0 : (when (setq val (plist-get entry :port))
511 0 : (oset backend port val)))
512 0 : backend)
513 :
514 : ;; (mapcar 'auth-source-backend-parse auth-sources)
515 :
516 : (cl-defun auth-source-search (&rest spec
517 : &key max require create delete
518 : &allow-other-keys)
519 : "Search or modify authentication backends according to SPEC.
520 :
521 : This function parses `auth-sources' for matches of the SPEC
522 : plist. It can optionally create or update an authentication
523 : token if requested. A token is just a standard Emacs property
524 : list with a :secret property that can be a function; all the
525 : other properties will always hold scalar values.
526 :
527 : Typically the :secret property, if present, contains a password.
528 :
529 : Common search keys are :max, :host, :port, and :user. In
530 : addition, :create specifies if and how tokens will be created.
531 : Finally, :type can specify which backend types you want to check.
532 :
533 : A string value is always matched literally. A symbol is matched
534 : as its string value, literally. All the SPEC values can be
535 : single values (symbol or string) or lists thereof (in which case
536 : any of the search terms matches).
537 :
538 : :create t means to create a token if possible.
539 :
540 : A new token will be created if no matching tokens were found.
541 : The new token will have only the keys the backend requires. For
542 : the netrc backend, for instance, that's the user, host, and
543 : port keys.
544 :
545 : Here's an example:
546 :
547 : \(let ((auth-source-creation-defaults \\='((user . \"defaultUser\")
548 : (A . \"default A\"))))
549 : (auth-source-search :host \"mine\" :type \\='netrc :max 1
550 : :P \"pppp\" :Q \"qqqq\"
551 : :create t))
552 :
553 : which says:
554 :
555 : \"Search for any entry matching host `mine' in backends of type
556 : `netrc', maximum one result.
557 :
558 : Create a new entry if you found none. The netrc backend will
559 : automatically require host, user, and port. The host will be
560 : `mine'. We prompt for the user with default `defaultUser' and
561 : for the port without a default. We will not prompt for A, Q,
562 : or P. The resulting token will only have keys user, host, and
563 : port.\"
564 :
565 : :create \\='(A B C) also means to create a token if possible.
566 :
567 : The behavior is like :create t but if the list contains any
568 : parameter, that parameter will be required in the resulting
569 : token. The value for that parameter will be obtained from the
570 : search parameters or from user input. If any queries are needed,
571 : the alist `auth-source-creation-defaults' will be checked for the
572 : default value. If the user, host, or port are missing, the alist
573 : `auth-source-creation-prompts' will be used to look up the
574 : prompts IN THAT ORDER (so the `user' prompt will be queried first,
575 : then `host', then `port', and finally `secret'). Each prompt string
576 : can use %u, %h, and %p to show the user, host, and port.
577 :
578 : Here's an example:
579 :
580 : \(let ((auth-source-creation-defaults \\='((user . \"defaultUser\")
581 : (A . \"default A\")))
582 : (auth-source-creation-prompts
583 : \\='((password . \"Enter IMAP password for %h:%p: \"))))
584 : (auth-source-search :host \\='(\"nonesuch\" \"twosuch\") :type \\='netrc :max 1
585 : :P \"pppp\" :Q \"qqqq\"
586 : :create \\='(A B Q)))
587 :
588 : which says:
589 :
590 : \"Search for any entry matching host `nonesuch'
591 : or `twosuch' in backends of type `netrc', maximum one result.
592 :
593 : Create a new entry if you found none. The netrc backend will
594 : automatically require host, user, and port. The host will be
595 : `nonesuch' and Q will be `qqqq'. We prompt for the password
596 : with the shown prompt. We will not prompt for Q. The resulting
597 : token will have keys user, host, port, A, B, and Q. It will not
598 : have P with any value, even though P is used in the search to
599 : find only entries that have P set to `pppp'.\"
600 :
601 : When multiple values are specified in the search parameter, the
602 : user is prompted for which one. So :host (X Y Z) would ask the
603 : user to choose between X, Y, and Z.
604 :
605 : This creation can fail if the search was not specific enough to
606 : create a new token (it's up to the backend to decide that). You
607 : should `catch' the backend-specific error as usual. Some
608 : backends (netrc, at least) will prompt the user rather than throw
609 : an error.
610 :
611 : :require (A B C) means that only results that contain those
612 : tokens will be returned. Thus for instance requiring :secret
613 : will ensure that any results will actually have a :secret
614 : property.
615 :
616 : :delete t means to delete any found entries. nil by default.
617 : Use `auth-source-delete' in ELisp code instead of calling
618 : `auth-source-search' directly with this parameter.
619 :
620 : :type (X Y Z) will check only those backend types. `netrc' and
621 : `secrets' are the only ones supported right now.
622 :
623 : :max N means to try to return at most N items (defaults to 1).
624 : More than N items may be returned, depending on the search and
625 : the backend.
626 :
627 : When :max is 0 the function will return just t or nil to indicate
628 : if any matches were found.
629 :
630 : :host (X Y Z) means to match only hosts X, Y, or Z according to
631 : the match rules above. Defaults to t.
632 :
633 : :user (X Y Z) means to match only users X, Y, or Z according to
634 : the match rules above. Defaults to t.
635 :
636 : :port (P Q R) means to match only protocols P, Q, or R.
637 : Defaults to t.
638 :
639 : :K (V1 V2 V3) for any other key K will match values V1, V2, or
640 : V3 (note the match rules above).
641 :
642 : The return value is a list with at most :max tokens. Each token
643 : is a plist with keys :backend :host :port :user, plus any other
644 : keys provided by the backend (notably :secret). But note the
645 : exception for :max 0, which see above.
646 :
647 : The token can hold a :save-function key. If you call that, the
648 : user will be prompted to save the data to the backend. You can't
649 : request that this should happen right after creation, because
650 : `auth-source-search' has no way of knowing if the token is
651 : actually useful. So the caller must arrange to call this function.
652 :
653 : The token's :secret key can hold a function. In that case you
654 : must call it to obtain the actual value."
655 0 : (let* ((backends (mapcar #'auth-source-backend-parse auth-sources))
656 0 : (max (or max 1))
657 : (ignored-keys '(:require :create :delete :max))
658 0 : (keys (cl-loop for i below (length spec) by 2
659 0 : unless (memq (nth i spec) ignored-keys)
660 0 : collect (nth i spec)))
661 0 : (cached (auth-source-remembered-p spec))
662 : ;; note that we may have cached results but found is still nil
663 : ;; (there were no results from the search)
664 0 : (found (auth-source-recall spec))
665 : filtered-backends)
666 :
667 0 : (if (and cached auth-source-do-cache)
668 0 : (auth-source-do-debug
669 : "auth-source-search: found %d CACHED results matching %S"
670 0 : (length found) spec)
671 :
672 0 : (cl-assert
673 0 : (or (eq t create) (listp create)) t
674 0 : "Invalid auth-source :create parameter (must be t or a list): %s %s")
675 :
676 0 : (cl-assert
677 0 : (listp require) t
678 0 : "Invalid auth-source :require parameter (must be a list): %s")
679 :
680 0 : (setq filtered-backends (copy-sequence backends))
681 0 : (dolist (backend backends)
682 0 : (cl-dolist (key keys)
683 : ;; ignore invalid slots
684 0 : (condition-case nil
685 0 : (unless (auth-source-search-collection
686 0 : (plist-get spec key)
687 0 : (slot-value backend key))
688 0 : (setq filtered-backends (delq backend filtered-backends))
689 0 : (cl-return))
690 0 : (invalid-slot-name nil))))
691 :
692 0 : (auth-source-do-trivia
693 : "auth-source-search: found %d backends matching %S"
694 0 : (length filtered-backends) spec)
695 :
696 : ;; (debug spec "filtered" filtered-backends)
697 : ;; First go through all the backends without :create, so we can
698 : ;; query them all.
699 0 : (setq found (auth-source-search-backends filtered-backends
700 0 : spec
701 : ;; to exit early
702 0 : max
703 : ;; create is always nil here
704 0 : nil delete
705 0 : require))
706 :
707 0 : (auth-source-do-debug
708 : "auth-source-search: found %d results (max %d) matching %S"
709 0 : (length found) max spec)
710 :
711 : ;; If we didn't find anything, then we allow the backend(s) to
712 : ;; create the entries.
713 0 : (when (and create
714 0 : (not found))
715 0 : (setq found (auth-source-search-backends filtered-backends
716 0 : spec
717 : ;; to exit early
718 0 : max
719 0 : create delete
720 0 : require))
721 0 : (auth-source-do-debug
722 : "auth-source-search: CREATED %d results (max %d) matching %S"
723 0 : (length found) max spec))
724 :
725 : ;; note we remember the lack of result too, if it's applicable
726 0 : (when auth-source-do-cache
727 0 : (auth-source-remember spec found)))
728 :
729 0 : (if (zerop max)
730 0 : (not (null found))
731 0 : found)))
732 :
733 : (defun auth-source-search-backends (backends spec max create delete require)
734 0 : (let ((max (if (zerop max) 1 max)) ; stop with 1 match if we're asked for zero
735 : matches)
736 0 : (dolist (backend backends)
737 0 : (when (> max (length matches)) ; if we need more matches...
738 0 : (let* ((bmatches (apply
739 0 : (slot-value backend 'search-function)
740 0 : :backend backend
741 0 : :type (slot-value backend 'type)
742 : ;; note we're overriding whatever the spec
743 : ;; has for :max, :require, :create, and :delete
744 0 : :max max
745 0 : :require require
746 0 : :create create
747 0 : :delete delete
748 0 : spec)))
749 0 : (when bmatches
750 0 : (auth-source-do-trivia
751 : "auth-source-search-backend: got %d (max %d) in %s:%s matching %S"
752 0 : (length bmatches) max
753 0 : (slot-value backend 'type)
754 0 : (slot-value backend 'source)
755 0 : spec)
756 0 : (setq matches (append matches bmatches))))))
757 0 : matches))
758 :
759 : (defun auth-source-delete (&rest spec)
760 : "Delete entries from the authentication backends according to SPEC.
761 : Calls `auth-source-search' with the :delete property in SPEC set to t.
762 : The backend may not actually delete the entries.
763 :
764 : Returns the deleted entries."
765 0 : (auth-source-search (plist-put spec :delete t)))
766 :
767 : (defun auth-source-search-collection (collection value)
768 : "Returns t is VALUE is t or COLLECTION is t or COLLECTION contains VALUE."
769 0 : (when (and (atom collection) (not (eq t collection)))
770 0 : (setq collection (list collection)))
771 :
772 : ;; (debug :collection collection :value value)
773 0 : (or (eq collection t)
774 0 : (eq value t)
775 0 : (equal collection value)
776 0 : (member value collection)))
777 :
778 : (defvar auth-source-netrc-cache nil)
779 :
780 : (defun auth-source-forget-all-cached ()
781 : "Forget all cached auth-source data."
782 : (interactive)
783 0 : (maphash (lambda (key _password)
784 0 : (when (eq 'auth-source (car-safe key))
785 : ;; remove that key
786 0 : (password-cache-remove key)))
787 0 : password-data)
788 0 : (setq auth-source-netrc-cache nil))
789 :
790 : (defun auth-source-format-cache-entry (spec)
791 : "Format SPEC entry to put it in the password cache."
792 2 : `(auth-source . ,spec))
793 :
794 : (defun auth-source-remember (spec found)
795 : "Remember FOUND search results for SPEC."
796 0 : (let ((password-cache-expiry auth-source-cache-expiry))
797 0 : (password-cache-add
798 0 : (auth-source-format-cache-entry spec) found)))
799 :
800 : (defun auth-source-recall (spec)
801 : "Recall FOUND search results for SPEC."
802 0 : (password-read-from-cache (auth-source-format-cache-entry spec)))
803 :
804 : (defun auth-source-remembered-p (spec)
805 : "Check if SPEC is remembered."
806 0 : (password-in-cache-p
807 0 : (auth-source-format-cache-entry spec)))
808 :
809 : (defun auth-source-forget (spec)
810 : "Forget any cached data matching SPEC exactly.
811 :
812 : This is the same SPEC you passed to `auth-source-search'.
813 : Returns t or nil for forgotten or not found."
814 2 : (password-cache-remove (auth-source-format-cache-entry spec)))
815 :
816 : (defun auth-source-forget+ (&rest spec)
817 : "Forget any cached data matching SPEC. Returns forgotten count.
818 :
819 : This is not a full `auth-source-search' spec but works similarly.
820 : For instance, \(:host \"myhost\" \"yourhost\") would find all the
821 : cached data that was found with a search for those two hosts,
822 : while \(:host t) would find all host entries."
823 0 : (let ((count 0))
824 0 : (maphash
825 : (lambda (key _password)
826 0 : (when (and (eq 'auth-source (car-safe key))
827 : ;; and the spec matches what was stored in the cache
828 0 : (auth-source-specmatchp spec (cdr key)))
829 : ;; remove that key
830 0 : (password-cache-remove key)
831 0 : (cl-incf count)))
832 0 : password-data)
833 0 : count))
834 :
835 : (defun auth-source-specmatchp (spec stored)
836 0 : (let ((keys (cl-loop for i below (length spec) by 2
837 0 : collect (nth i spec))))
838 0 : (not (eq
839 0 : (cl-dolist (key keys)
840 0 : (unless (auth-source-search-collection (plist-get stored key)
841 0 : (plist-get spec key))
842 0 : (cl-return 'no)))
843 0 : 'no))))
844 :
845 : (defun auth-source-pick-first-password (&rest spec)
846 : "Pick the first secret found from applying SPEC to `auth-source-search'."
847 0 : (let* ((result (nth 0 (apply #'auth-source-search (plist-put spec :max 1))))
848 0 : (secret (plist-get result :secret)))
849 :
850 0 : (if (functionp secret)
851 0 : (funcall secret)
852 0 : secret)))
853 :
854 : (defun auth-source-format-prompt (prompt alist)
855 : "Format PROMPT using %x (for any character x) specifiers in ALIST."
856 0 : (dolist (cell alist)
857 0 : (let ((c (nth 0 cell))
858 0 : (v (nth 1 cell)))
859 0 : (when (and c v)
860 0 : (setq prompt (replace-regexp-in-string (format "%%%c" c)
861 0 : (format "%s" v)
862 0 : prompt nil t)))))
863 0 : prompt)
864 :
865 : (defun auth-source-ensure-strings (values)
866 0 : (if (eq values t)
867 0 : values
868 0 : (unless (listp values)
869 0 : (setq values (list values)))
870 0 : (mapcar (lambda (value)
871 0 : (if (numberp value)
872 0 : (format "%s" value)
873 0 : value))
874 0 : values)))
875 :
876 : ;;; Backend specific parsing: netrc/authinfo backend
877 :
878 : (defun auth-source--aput-1 (alist key val)
879 0 : (let ((seen ())
880 0 : (rest alist))
881 0 : (while (and (consp rest) (not (equal key (caar rest))))
882 0 : (push (pop rest) seen))
883 0 : (cons (cons key val)
884 0 : (if (null rest) alist
885 0 : (nconc (nreverse seen)
886 0 : (if (equal key (caar rest)) (cdr rest) rest))))))
887 : (defmacro auth-source--aput (var key val)
888 6 : `(setq ,var (auth-source--aput-1 ,var ,key ,val)))
889 :
890 : (defun auth-source--aget (alist key)
891 0 : (cdr (assoc key alist)))
892 :
893 : ;; (auth-source-netrc-parse :file "~/.authinfo.gpg")
894 : (cl-defun auth-source-netrc-parse (&key file max host user port require
895 : &allow-other-keys)
896 : "Parse FILE and return a list of all entries in the file.
897 : Note that the MAX parameter is used so we can exit the parse early."
898 0 : (if (listp file)
899 : ;; We got already parsed contents; just return it.
900 0 : file
901 0 : (when (file-exists-p file)
902 0 : (setq port (auth-source-ensure-strings port))
903 0 : (with-temp-buffer
904 0 : (let* ((max (or max 5000)) ; sanity check: default to stop at 5K
905 : (modified 0)
906 0 : (cached (cdr-safe (assoc file auth-source-netrc-cache)))
907 0 : (cached-mtime (plist-get cached :mtime))
908 0 : (cached-secrets (plist-get cached :secret))
909 : (check (lambda(alist)
910 0 : (and alist
911 0 : (auth-source-search-collection
912 0 : host
913 0 : (or
914 0 : (auth-source--aget alist "machine")
915 0 : (auth-source--aget alist "host")
916 0 : t))
917 0 : (auth-source-search-collection
918 0 : user
919 0 : (or
920 0 : (auth-source--aget alist "login")
921 0 : (auth-source--aget alist "account")
922 0 : (auth-source--aget alist "user")
923 0 : t))
924 0 : (auth-source-search-collection
925 0 : port
926 0 : (or
927 0 : (auth-source--aget alist "port")
928 0 : (auth-source--aget alist "protocol")
929 0 : t))
930 0 : (or
931 : ;; the required list of keys is nil, or
932 0 : (null require)
933 : ;; every element of require is in n (normalized)
934 0 : (let ((n (nth 0 (auth-source-netrc-normalize
935 0 : (list alist) file))))
936 0 : (cl-loop for req in require
937 0 : always (plist-get n req)))))))
938 : result)
939 :
940 0 : (if (and (functionp cached-secrets)
941 0 : (equal cached-mtime
942 0 : (nth 5 (file-attributes file))))
943 0 : (progn
944 0 : (auth-source-do-trivia
945 : "auth-source-netrc-parse: using CACHED file data for %s"
946 0 : file)
947 0 : (insert (funcall cached-secrets)))
948 0 : (insert-file-contents file)
949 : ;; cache all netrc files (used to be just .gpg files)
950 : ;; Store the contents of the file heavily encrypted in memory.
951 : ;; (note for the irony-impaired: they are just obfuscated)
952 0 : (auth-source--aput
953 : auth-source-netrc-cache file
954 : (list :mtime (nth 5 (file-attributes file))
955 : :secret (let ((v (mapcar #'1+ (buffer-string))))
956 0 : (lambda () (apply #'string (mapcar #'1- v)))))))
957 0 : (goto-char (point-min))
958 0 : (let ((entries (auth-source-netrc-parse-entries check max))
959 : alist)
960 0 : (while (setq alist (pop entries))
961 0 : (push (nreverse alist) result)))
962 :
963 0 : (when (< 0 modified)
964 0 : (when auth-source-gpg-encrypt-to
965 : ;; (see bug#7487) making `epa-file-encrypt-to' local to
966 : ;; this buffer lets epa-file skip the key selection query
967 : ;; (see the `local-variable-p' check in
968 : ;; `epa-file-write-region').
969 0 : (unless (local-variable-p 'epa-file-encrypt-to (current-buffer))
970 0 : (make-local-variable 'epa-file-encrypt-to))
971 0 : (if (listp auth-source-gpg-encrypt-to)
972 0 : (setq epa-file-encrypt-to auth-source-gpg-encrypt-to)))
973 :
974 : ;; ask AFTER we've successfully opened the file
975 0 : (when (y-or-n-p (format "Save file %s? (%d deletions)"
976 0 : file modified))
977 0 : (write-region (point-min) (point-max) file nil 'silent)
978 0 : (auth-source-do-debug
979 : "auth-source-netrc-parse: modified %d lines in %s"
980 0 : modified file)))
981 :
982 0 : (nreverse result))))))
983 :
984 : (defun auth-source-netrc-parse-next-interesting ()
985 : "Advance to the next interesting position in the current buffer."
986 : ;; If we're looking at a comment or are at the end of the line, move forward
987 0 : (while (or (looking-at "#")
988 0 : (and (eolp)
989 0 : (not (eobp))))
990 0 : (forward-line 1))
991 0 : (skip-chars-forward "\t "))
992 :
993 : (defun auth-source-netrc-parse-one ()
994 : "Read one thing from the current buffer."
995 0 : (auth-source-netrc-parse-next-interesting)
996 :
997 0 : (when (or (looking-at "'\\([^']*\\)'")
998 0 : (looking-at "\"\\([^\"]*\\)\"")
999 0 : (looking-at "\\([^ \t\n]+\\)"))
1000 0 : (forward-char (length (match-string 0)))
1001 0 : (auth-source-netrc-parse-next-interesting)
1002 0 : (match-string-no-properties 1)))
1003 :
1004 : ;; with thanks to org-mode
1005 : (defsubst auth-source-current-line (&optional pos)
1006 0 : (save-excursion
1007 0 : (and pos (goto-char pos))
1008 : ;; works also in narrowed buffer, because we start at 1, not point-min
1009 0 : (+ (if (bolp) 1 0) (count-lines 1 (point)))))
1010 :
1011 : (defun auth-source-netrc-parse-entries(check max)
1012 : "Parse up to MAX netrc entries, passed by CHECK, from the current buffer."
1013 0 : (let ((adder (lambda(check alist all)
1014 0 : (when (and
1015 0 : alist
1016 0 : (> max (length all))
1017 0 : (funcall check alist))
1018 0 : (push alist all))
1019 0 : all))
1020 : item item2 all alist default)
1021 0 : (while (setq item (auth-source-netrc-parse-one))
1022 0 : (setq default (equal item "default"))
1023 : ;; We're starting a new machine. Save the old one.
1024 0 : (when (and alist
1025 0 : (or default
1026 0 : (equal item "machine")))
1027 : ;; (auth-source-do-trivia
1028 : ;; "auth-source-netrc-parse-entries: got entry %S" alist)
1029 0 : (setq all (funcall adder check alist all)
1030 0 : alist nil))
1031 : ;; In default entries, we don't have a next token.
1032 : ;; We store them as ("machine" . t)
1033 0 : (if default
1034 0 : (push (cons "machine" t) alist)
1035 : ;; Not a default entry. Grab the next item.
1036 0 : (when (setq item2 (auth-source-netrc-parse-one))
1037 : ;; Did we get a "machine" value?
1038 0 : (if (equal item2 "machine")
1039 0 : (error
1040 : "%s: Unexpected `machine' token at line %d"
1041 : "auth-source-netrc-parse-entries"
1042 0 : (auth-source-current-line))
1043 0 : (push (cons item item2) alist)))))
1044 :
1045 : ;; Clean up: if there's an entry left over, use it.
1046 0 : (when alist
1047 0 : (setq all (funcall adder check alist all))
1048 : ;; (auth-source-do-trivia
1049 : ;; "auth-source-netrc-parse-entries: got2 entry %S" alist)
1050 0 : )
1051 0 : (nreverse all)))
1052 :
1053 : (defvar auth-source-passphrase-alist nil)
1054 :
1055 : (defun auth-source-token-passphrase-callback-function (_context _key-id file)
1056 0 : (let* ((file (file-truename file))
1057 0 : (entry (assoc file auth-source-passphrase-alist))
1058 : passphrase)
1059 : ;; return the saved passphrase, calling a function if needed
1060 0 : (or (copy-sequence (if (functionp (cdr entry))
1061 0 : (funcall (cdr entry))
1062 0 : (cdr entry)))
1063 0 : (progn
1064 0 : (unless entry
1065 0 : (setq entry (list file))
1066 0 : (push entry auth-source-passphrase-alist))
1067 0 : (setq passphrase
1068 0 : (read-passwd
1069 0 : (format "Passphrase for %s tokens: " file)
1070 0 : t))
1071 0 : (setcdr entry (let ((p (copy-sequence passphrase)))
1072 0 : (lambda () p)))
1073 0 : passphrase))))
1074 :
1075 : (defun auth-source-epa-extract-gpg-token (secret file)
1076 : "Pass either the decoded SECRET or the gpg:BASE64DATA version.
1077 : FILE is the file from which we obtained this token."
1078 0 : (when (string-match "^gpg:\\(.+\\)" secret)
1079 0 : (setq secret (base64-decode-string (match-string 1 secret))))
1080 0 : (let ((context (epg-make-context 'OpenPGP)))
1081 0 : (epg-context-set-passphrase-callback
1082 0 : context
1083 0 : (cons #'auth-source-token-passphrase-callback-function
1084 0 : file))
1085 0 : (epg-decrypt-string context secret)))
1086 :
1087 : (defvar pp-escape-newlines)
1088 :
1089 : (defun auth-source-epa-make-gpg-token (secret file)
1090 0 : (let ((context (epg-make-context 'OpenPGP))
1091 : (pp-escape-newlines nil)
1092 : cipher)
1093 0 : (setf (epg-context-armor context) t)
1094 0 : (epg-context-set-passphrase-callback
1095 0 : context
1096 0 : (cons #'auth-source-token-passphrase-callback-function
1097 0 : file))
1098 0 : (setq cipher (epg-encrypt-string context secret nil))
1099 0 : (with-temp-buffer
1100 0 : (insert cipher)
1101 0 : (base64-encode-region (point-min) (point-max) t)
1102 0 : (concat "gpg:" (buffer-substring-no-properties
1103 0 : (point-min)
1104 0 : (point-max))))))
1105 :
1106 : (defun auth-source--symbol-keyword (symbol)
1107 0 : (intern (format ":%s" symbol)))
1108 :
1109 : (defun auth-source-netrc-normalize (alist filename)
1110 0 : (mapcar (lambda (entry)
1111 0 : (let (ret item)
1112 0 : (while (setq item (pop entry))
1113 0 : (let ((k (car item))
1114 0 : (v (cdr item)))
1115 :
1116 : ;; apply key aliases
1117 0 : (setq k (cond ((member k '("machine")) "host")
1118 0 : ((member k '("login" "account")) "user")
1119 0 : ((member k '("protocol")) "port")
1120 0 : ((member k '("password")) "secret")
1121 0 : (t k)))
1122 :
1123 : ;; send back the secret in a function (lexical binding)
1124 0 : (when (equal k "secret")
1125 0 : (setq v (let ((lexv v)
1126 : (token-decoder nil))
1127 0 : (when (string-match "^gpg:" lexv)
1128 : ;; it's a GPG token: create a token decoder
1129 : ;; which unsets itself once
1130 0 : (setq token-decoder
1131 : (lambda (val)
1132 0 : (prog1
1133 0 : (auth-source-epa-extract-gpg-token
1134 0 : val
1135 0 : filename)
1136 0 : (setq token-decoder nil)))))
1137 : (lambda ()
1138 0 : (when token-decoder
1139 0 : (setq lexv (funcall token-decoder lexv)))
1140 0 : lexv))))
1141 0 : (setq ret (plist-put ret
1142 0 : (auth-source--symbol-keyword k)
1143 0 : v))))
1144 0 : ret))
1145 0 : alist))
1146 :
1147 : (cl-defun auth-source-netrc-search (&rest spec
1148 : &key backend require create
1149 : type max host user port
1150 : &allow-other-keys)
1151 : "Given a property list SPEC, return search matches from the :backend.
1152 : See `auth-source-search' for details on SPEC."
1153 : ;; just in case, check that the type is correct (null or same as the backend)
1154 0 : (cl-assert (or (null type) (eq type (oref backend type)))
1155 0 : t "Invalid netrc search: %s %s")
1156 :
1157 0 : (let ((results (auth-source-netrc-normalize
1158 0 : (auth-source-netrc-parse
1159 0 : :max max
1160 0 : :require require
1161 0 : :file (oref backend source)
1162 0 : :host (or host t)
1163 0 : :user (or user t)
1164 0 : :port (or port t))
1165 0 : (oref backend source))))
1166 :
1167 : ;; if we need to create an entry AND none were found to match
1168 0 : (when (and create
1169 0 : (not results))
1170 :
1171 : ;; create based on the spec and record the value
1172 0 : (setq results (or
1173 : ;; if the user did not want to create the entry
1174 : ;; in the file, it will be returned
1175 0 : (apply (slot-value backend 'create-function) spec)
1176 : ;; if not, we do the search again without :create
1177 : ;; to get the updated data.
1178 :
1179 : ;; the result will be returned, even if the search fails
1180 0 : (apply #'auth-source-netrc-search
1181 0 : (plist-put spec :create nil)))))
1182 0 : results))
1183 :
1184 : (defun auth-source-netrc-element-or-first (v)
1185 0 : (if (listp v)
1186 0 : (nth 0 v)
1187 0 : v))
1188 :
1189 : ;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t)
1190 : ;; (auth-source-search :host "nonesuch" :type 'netrc :max 1 :create t :create-extra-keys '((A "default A") (B)))
1191 :
1192 : (cl-defun auth-source-netrc-create (&rest spec
1193 : &key backend host port create
1194 : &allow-other-keys)
1195 0 : (let* ((base-required '(host user port secret))
1196 : ;; we know (because of an assertion in auth-source-search) that the
1197 : ;; :create parameter is either t or a list (which includes nil)
1198 0 : (create-extra (if (eq t create) nil create))
1199 0 : (current-data (car (auth-source-search :max 1
1200 0 : :host host
1201 0 : :port port)))
1202 0 : (required (append base-required create-extra))
1203 0 : (file (oref backend source))
1204 : (add "")
1205 : ;; `valist' is an alist
1206 : valist
1207 : ;; `artificial' will be returned if no creation is needed
1208 : artificial)
1209 :
1210 : ;; only for base required elements (defined as function parameters):
1211 : ;; fill in the valist with whatever data we may have from the search
1212 : ;; we complete the first value if it's a list and use the value otherwise
1213 0 : (dolist (br base-required)
1214 0 : (let ((val (plist-get spec (auth-source--symbol-keyword br))))
1215 0 : (when val
1216 0 : (let ((br-choice (cond
1217 : ;; all-accepting choice (predicate is t)
1218 0 : ((eq t val) nil)
1219 : ;; just the value otherwise
1220 0 : (t val))))
1221 0 : (when br-choice
1222 0 : (auth-source--aput valist br br-choice))))))
1223 :
1224 : ;; for extra required elements, see if the spec includes a value for them
1225 0 : (dolist (er create-extra)
1226 0 : (let ((k (auth-source--symbol-keyword er))
1227 0 : (keys (cl-loop for i below (length spec) by 2
1228 0 : collect (nth i spec))))
1229 0 : (when (memq k keys)
1230 0 : (auth-source--aput valist er (plist-get spec k)))))
1231 :
1232 : ;; for each required element
1233 0 : (dolist (r required)
1234 0 : (let* ((data (auth-source--aget valist r))
1235 : ;; take the first element if the data is a list
1236 0 : (data (or (auth-source-netrc-element-or-first data)
1237 0 : (plist-get current-data
1238 0 : (auth-source--symbol-keyword r))))
1239 : ;; this is the default to be offered
1240 0 : (given-default (auth-source--aget
1241 0 : auth-source-creation-defaults r))
1242 : ;; the default supplementals are simple:
1243 : ;; for the user, try `given-default' and then (user-login-name);
1244 : ;; otherwise take `given-default'
1245 0 : (default (cond
1246 0 : ((and (not given-default) (eq r 'user))
1247 0 : (user-login-name))
1248 0 : (t given-default)))
1249 0 : (printable-defaults (list
1250 0 : (cons 'user
1251 0 : (or
1252 0 : (auth-source-netrc-element-or-first
1253 0 : (auth-source--aget valist 'user))
1254 0 : (plist-get artificial :user)
1255 0 : "[any user]"))
1256 0 : (cons 'host
1257 0 : (or
1258 0 : (auth-source-netrc-element-or-first
1259 0 : (auth-source--aget valist 'host))
1260 0 : (plist-get artificial :host)
1261 0 : "[any host]"))
1262 0 : (cons 'port
1263 0 : (or
1264 0 : (auth-source-netrc-element-or-first
1265 0 : (auth-source--aget valist 'port))
1266 0 : (plist-get artificial :port)
1267 0 : "[any port]"))))
1268 0 : (prompt (or (auth-source--aget auth-source-creation-prompts r)
1269 0 : (cl-case r
1270 : (secret "%p password for %u@%h: ")
1271 : (user "%p user name for %h: ")
1272 : (host "%p host name for user %u: ")
1273 0 : (port "%p port for %u@%h: "))
1274 0 : (format "Enter %s (%%u@%%h:%%p): " r)))
1275 0 : (prompt (auth-source-format-prompt
1276 0 : prompt
1277 0 : `((?u ,(auth-source--aget printable-defaults 'user))
1278 0 : (?h ,(auth-source--aget printable-defaults 'host))
1279 0 : (?p ,(auth-source--aget printable-defaults 'port))))))
1280 :
1281 : ;; Store the data, prompting for the password if needed.
1282 0 : (setq data (or data
1283 0 : (if (eq r 'secret)
1284 : ;; Special case prompt for passwords.
1285 : ;; TODO: make the default (setq auth-source-netrc-use-gpg-tokens `((,(if (boundp 'epa-file-auto-mode-alist-entry) (car epa-file-auto-mode-alist-entry) "\\.gpg\\'") nil) (t gpg)))
1286 : ;; TODO: or maybe leave as (setq auth-source-netrc-use-gpg-tokens 'never)
1287 0 : (let* ((ep (format "Use GPG password tokens in %s?" file))
1288 : (gpg-encrypt
1289 0 : (cond
1290 0 : ((eq auth-source-netrc-use-gpg-tokens 'never)
1291 : 'never)
1292 0 : ((listp auth-source-netrc-use-gpg-tokens)
1293 0 : (let ((check (copy-sequence
1294 0 : auth-source-netrc-use-gpg-tokens))
1295 : item ret)
1296 0 : (while check
1297 0 : (setq item (pop check))
1298 0 : (when (or (eq (car item) t)
1299 0 : (string-match (car item) file))
1300 0 : (setq ret (cdr item))
1301 0 : (setq check nil)))
1302 : ;; FIXME: `ret' unused.
1303 : ;; Should we return it here?
1304 0 : ))
1305 0 : (t 'never)))
1306 0 : (plain (or (eval default) (read-passwd prompt))))
1307 : ;; ask if we don't know what to do (in which case
1308 : ;; auth-source-netrc-use-gpg-tokens must be a list)
1309 0 : (unless gpg-encrypt
1310 0 : (setq gpg-encrypt (if (y-or-n-p ep) 'gpg 'never))
1311 : ;; TODO: save the defcustom now? or ask?
1312 0 : (setq auth-source-netrc-use-gpg-tokens
1313 0 : (cons `(,file ,gpg-encrypt)
1314 0 : auth-source-netrc-use-gpg-tokens)))
1315 0 : (if (eq gpg-encrypt 'gpg)
1316 0 : (auth-source-epa-make-gpg-token plain file)
1317 0 : plain))
1318 0 : (if (stringp default)
1319 0 : (read-string (if (string-match ": *\\'" prompt)
1320 0 : (concat (substring prompt 0 (match-beginning 0))
1321 0 : " (default " default "): ")
1322 0 : (concat prompt "(default " default ") "))
1323 0 : nil nil default)
1324 0 : (eval default)))))
1325 :
1326 0 : (when data
1327 0 : (setq artificial (plist-put artificial
1328 0 : (auth-source--symbol-keyword r)
1329 0 : (if (eq r 'secret)
1330 0 : (let ((data data))
1331 0 : (lambda () data))
1332 0 : data))))
1333 :
1334 : ;; When r is not an empty string...
1335 0 : (when (and (stringp data)
1336 0 : (< 0 (length data)))
1337 : ;; this function is not strictly necessary but I think it
1338 : ;; makes the code clearer -tzz
1339 0 : (let ((printer (lambda ()
1340 : ;; append the key (the symbol name of r)
1341 : ;; and the value in r
1342 0 : (format "%s%s %s"
1343 : ;; prepend a space
1344 0 : (if (zerop (length add)) "" " ")
1345 : ;; remap auth-source tokens to netrc
1346 0 : (cl-case r
1347 : (user "login")
1348 : (host "machine")
1349 : (secret "password")
1350 : (port "port") ; redundant but clearer
1351 0 : (t (symbol-name r)))
1352 0 : (if (string-match "[\"# ]" data)
1353 0 : (format "%S" data)
1354 0 : data)))))
1355 0 : (setq add (concat add (funcall printer)))))))
1356 :
1357 0 : (plist-put
1358 0 : artificial
1359 : :save-function
1360 0 : (let ((file file)
1361 0 : (add add))
1362 0 : (lambda () (auth-source-netrc-saver file add))))
1363 :
1364 0 : (list artificial)))
1365 :
1366 : (defun auth-source-netrc-saver (file add)
1367 : "Save a line ADD in FILE, prompting along the way.
1368 : Respects `auth-source-save-behavior'. Uses
1369 : `auth-source-netrc-cache' to avoid prompting more than once."
1370 0 : (let* ((key (format "%s %s" file (rfc2104-hash 'md5 64 16 file add)))
1371 0 : (cached (assoc key auth-source-netrc-cache)))
1372 :
1373 0 : (if cached
1374 0 : (auth-source-do-trivia
1375 : "auth-source-netrc-saver: found previous run for key %s, returning"
1376 0 : key)
1377 0 : (with-temp-buffer
1378 0 : (when (file-exists-p file)
1379 0 : (insert-file-contents file))
1380 0 : (when auth-source-gpg-encrypt-to
1381 : ;; (see bug#7487) making `epa-file-encrypt-to' local to
1382 : ;; this buffer lets epa-file skip the key selection query
1383 : ;; (see the `local-variable-p' check in
1384 : ;; `epa-file-write-region').
1385 0 : (unless (local-variable-p 'epa-file-encrypt-to (current-buffer))
1386 0 : (make-local-variable 'epa-file-encrypt-to))
1387 0 : (if (listp auth-source-gpg-encrypt-to)
1388 0 : (setq epa-file-encrypt-to auth-source-gpg-encrypt-to)))
1389 : ;; we want the new data to be found first, so insert at beginning
1390 0 : (goto-char (point-min))
1391 :
1392 : ;; Ask AFTER we've successfully opened the file.
1393 0 : (let ((prompt (format "Save auth info to file %s? " file))
1394 0 : (done (not (eq auth-source-save-behavior 'ask)))
1395 : (bufname "*auth-source Help*")
1396 : k)
1397 0 : (while (not done)
1398 0 : (setq k (auth-source-read-char-choice prompt '(?y ?n ?N ?e ??)))
1399 0 : (cl-case k
1400 0 : (?y (setq done t))
1401 0 : (?? (save-excursion
1402 0 : (with-output-to-temp-buffer bufname
1403 0 : (princ
1404 0 : (concat "(y)es, save\n"
1405 : "(n)o but use the info\n"
1406 : "(N)o and don't ask to save again\n"
1407 : "(e)dit the line\n"
1408 0 : "(?) for help as you can see.\n"))
1409 : ;; Why? Doesn't with-output-to-temp-buffer already do
1410 : ;; the exact same thing anyway? --Stef
1411 0 : (set-buffer standard-output)
1412 0 : (help-mode))))
1413 0 : (?n (setq add ""
1414 0 : done t))
1415 : (?N
1416 0 : (setq add ""
1417 0 : done t)
1418 0 : (customize-save-variable 'auth-source-save-behavior nil))
1419 0 : (?e (setq add (read-string "Line to add: " add)))
1420 0 : (t nil)))
1421 :
1422 0 : (when (get-buffer-window bufname)
1423 0 : (delete-window (get-buffer-window bufname)))
1424 :
1425 : ;; Make sure the info is not saved.
1426 0 : (when (null auth-source-save-behavior)
1427 0 : (setq add ""))
1428 :
1429 0 : (when (< 0 (length add))
1430 0 : (progn
1431 0 : (unless (bolp)
1432 0 : (insert "\n"))
1433 0 : (insert add "\n")
1434 0 : (write-region (point-min) (point-max) file nil 'silent)
1435 : ;; Make the .authinfo file non-world-readable.
1436 0 : (set-file-modes file #o600)
1437 0 : (auth-source-do-debug
1438 : "auth-source-netrc-create: wrote 1 new line to %s"
1439 0 : file)
1440 0 : (message "Saved new authentication information to %s" file)
1441 0 : nil))))
1442 0 : (auth-source--aput auth-source-netrc-cache key "ran"))))
1443 :
1444 : ;;; Backend specific parsing: Secrets API backend
1445 :
1446 : (defun auth-source-secrets-listify-pattern (pattern)
1447 : "Convert a pattern with lists to a list of string patterns.
1448 :
1449 : auth-source patterns can have values of the form :foo (\"bar\"
1450 : \"qux\"), which means to match any secret with :foo equal to
1451 : \"bar\" or :foo equal to \"qux\". The secrets backend supports
1452 : only string values for patterns, so this routine returns a list
1453 : of patterns that is equivalent to the single original pattern
1454 : when interpreted such that if a secret matches any pattern in the
1455 : list, it matches the original pattern."
1456 0 : (if (null pattern)
1457 : '(nil)
1458 0 : (let* ((key (pop pattern))
1459 0 : (value (pop pattern))
1460 0 : (tails (auth-source-secrets-listify-pattern pattern))
1461 0 : (heads (if (stringp value)
1462 0 : (list (list key value))
1463 0 : (mapcar (lambda (v) (list key v)) value))))
1464 0 : (cl-loop for h in heads
1465 0 : nconc (cl-loop for tl in tails collect (append h tl))))))
1466 :
1467 : (cl-defun auth-source-secrets-search (&rest spec
1468 : &key backend create delete label max
1469 : &allow-other-keys)
1470 : "Search the Secrets API; spec is like `auth-source'.
1471 :
1472 : The :label key specifies the item's label. It is the only key
1473 : that can specify a substring. Any :label value besides a string
1474 : will allow any label.
1475 :
1476 : All other search keys must match exactly. If you need substring
1477 : matching, do a wider search and narrow it down yourself.
1478 :
1479 : You'll get back all the properties of the token as a plist.
1480 :
1481 : Here's an example that looks for the first item in the `Login'
1482 : Secrets collection:
1483 :
1484 : (let ((auth-sources \\='(\"secrets:Login\")))
1485 : (auth-source-search :max 1)
1486 :
1487 : Here's another that looks for the first item in the `Login'
1488 : Secrets collection whose label contains `gnus':
1489 :
1490 : (let ((auth-sources \\='(\"secrets:Login\")))
1491 : (auth-source-search :max 1 :label \"gnus\")
1492 :
1493 : And this one looks for the first item in the `Login' Secrets
1494 : collection that's a Google Chrome entry for the git.gnus.org site
1495 : authentication tokens:
1496 :
1497 : (let ((auth-sources \\='(\"secrets:Login\")))
1498 : (auth-source-search :max 1 :signon_realm \"https://git.gnus.org/Git\"))
1499 : "
1500 :
1501 : ;; TODO
1502 0 : (cl-assert (not create) nil
1503 0 : "The Secrets API auth-source backend doesn't support creation yet")
1504 : ;; TODO
1505 : ;; (secrets-delete-item coll elt)
1506 0 : (cl-assert (not delete) nil
1507 0 : "The Secrets API auth-source backend doesn't support deletion yet")
1508 :
1509 0 : (let* ((coll (oref backend source))
1510 0 : (max (or max 5000)) ; sanity check: default to stop at 5K
1511 : (ignored-keys '(:create :delete :max :backend :label :require :type))
1512 0 : (search-keys (cl-loop for i below (length spec) by 2
1513 0 : unless (memq (nth i spec) ignored-keys)
1514 0 : collect (nth i spec)))
1515 : ;; build a search spec without the ignored keys
1516 : ;; if a search key is nil or t (match anything), we skip it
1517 0 : (search-specs (auth-source-secrets-listify-pattern
1518 0 : (apply #'append (mapcar
1519 : (lambda (k)
1520 0 : (if (or (null (plist-get spec k))
1521 0 : (eq t (plist-get spec k)))
1522 : nil
1523 0 : (list k (plist-get spec k))))
1524 0 : search-keys))))
1525 : ;; needed keys (always including host, login, port, and secret)
1526 0 : (returned-keys (delete-dups (append
1527 : '(:host :login :port :secret)
1528 0 : search-keys)))
1529 : (items
1530 0 : (cl-loop
1531 0 : for search-spec in search-specs
1532 : nconc
1533 0 : (cl-loop for item in (apply #'secrets-search-items coll search-spec)
1534 0 : unless (and (stringp label)
1535 0 : (not (string-match label item)))
1536 0 : collect item)))
1537 : ;; TODO: respect max in `secrets-search-items', not after the fact
1538 0 : (items (butlast items (- (length items) max)))
1539 : ;; convert the item name to a full plist
1540 0 : (items (mapcar (lambda (item)
1541 0 : (append
1542 : ;; make an entry for the secret (password) element
1543 0 : (list
1544 : :secret
1545 0 : (let ((v (secrets-get-secret coll item)))
1546 0 : (lambda () v)))
1547 : ;; rewrite the entry from ((k1 v1) (k2 v2)) to plist
1548 0 : (apply #'append
1549 0 : (mapcar (lambda (entry)
1550 0 : (list (car entry) (cdr entry)))
1551 0 : (secrets-get-attributes coll item)))))
1552 0 : items))
1553 : ;; ensure each item has each key in `returned-keys'
1554 0 : (items (mapcar (lambda (plist)
1555 0 : (append
1556 0 : (apply #'append
1557 0 : (mapcar (lambda (req)
1558 0 : (if (plist-get plist req)
1559 : nil
1560 0 : (list req nil)))
1561 0 : returned-keys))
1562 0 : plist))
1563 0 : items)))
1564 0 : items))
1565 :
1566 : (defun auth-source-secrets-create (&rest spec)
1567 : ;; TODO
1568 : ;; (apply 'secrets-create-item (auth-get-source entry) name passwd spec)
1569 0 : (debug spec))
1570 :
1571 : ;;; Backend specific parsing: Mac OS Keychain (using /usr/bin/security) backend
1572 :
1573 : (cl-defun auth-source-macos-keychain-search (&rest spec
1574 : &key backend create delete type max
1575 : &allow-other-keys)
1576 : "Search the macOS Keychain; spec is like `auth-source'.
1577 :
1578 : All search keys must match exactly. If you need substring
1579 : matching, do a wider search and narrow it down yourself.
1580 :
1581 : You'll get back all the properties of the token as a plist.
1582 :
1583 : The :type key is either `macos-keychain-internet' or
1584 : `macos-keychain-generic'.
1585 :
1586 : For the internet keychain type, the :label key searches the
1587 : item's labels (\"-l LABEL\" passed to \"/usr/bin/security\").
1588 : Similarly, :host maps to \"-s HOST\", :user maps to \"-a USER\",
1589 : and :port maps to \"-P PORT\" or \"-r PROT\"
1590 : \(note PROT has to be a 4-character string).
1591 :
1592 : For the generic keychain type, the :label key searches the item's
1593 : labels (\"-l LABEL\" passed to \"/usr/bin/security\").
1594 : Similarly, :host maps to \"-c HOST\" (the \"creator\" keychain
1595 : field), :user maps to \"-a USER\", and :port maps to \"-s PORT\".
1596 :
1597 : Here's an example that looks for the first item in the default
1598 : generic macOS Keychain:
1599 :
1600 : (let ((auth-sources \\='(macos-keychain-generic)))
1601 : (auth-source-search :max 1)
1602 :
1603 : Here's another that looks for the first item in the internet
1604 : macOS Keychain collection whose label is `gnus':
1605 :
1606 : (let ((auth-sources \\='(macos-keychain-internet)))
1607 : (auth-source-search :max 1 :label \"gnus\")
1608 :
1609 : And this one looks for the first item in the internet keychain
1610 : entries for git.gnus.org:
1611 :
1612 : (let ((auth-sources \\='(macos-keychain-internet\")))
1613 : (auth-source-search :max 1 :host \"git.gnus.org\"))
1614 : "
1615 : ;; TODO
1616 0 : (cl-assert (not create) nil
1617 0 : "The macOS Keychain auth-source backend doesn't support creation yet")
1618 : ;; TODO
1619 : ;; (macos-keychain-delete-item coll elt)
1620 0 : (cl-assert (not delete) nil
1621 0 : "The macOS Keychain auth-source backend doesn't support deletion yet")
1622 :
1623 0 : (let* ((coll (oref backend source))
1624 0 : (max (or max 5000)) ; sanity check: default to stop at 5K
1625 : ;; Filter out ignored keys from the spec
1626 : (ignored-keys '(:create :delete :max :backend :label :host :port))
1627 : ;; Build a search spec without the ignored keys
1628 : ;; FIXME make this loop a function? it's used in at least 3 places
1629 0 : (search-keys (cl-loop for i below (length spec) by 2
1630 0 : unless (memq (nth i spec) ignored-keys)
1631 0 : collect (nth i spec)))
1632 : ;; If a search key value is nil or t (match anything), we skip it
1633 0 : (search-spec (apply #'append (mapcar
1634 : (lambda (k)
1635 0 : (if (or (null (plist-get spec k))
1636 0 : (eq t (plist-get spec k)))
1637 : nil
1638 0 : (list k (plist-get spec k))))
1639 0 : search-keys)))
1640 : ;; needed keys (always including host, login, port, and secret)
1641 0 : (returned-keys (delete-dups (append
1642 : '(:host :login :port :secret)
1643 0 : search-keys)))
1644 : ;; Extract host and port from spec
1645 0 : (hosts (plist-get spec :host))
1646 0 : (hosts (if (and hosts (listp hosts)) hosts `(,hosts)))
1647 0 : (ports (plist-get spec :port))
1648 0 : (ports (if (and ports (listp ports)) ports `(,ports)))
1649 : ;; Loop through all combinations of host/port and pass each of these to
1650 : ;; auth-source-macos-keychain-search-items
1651 0 : (items (catch 'match
1652 0 : (dolist (host hosts)
1653 0 : (dolist (port ports)
1654 0 : (let* ((port (if port (format "%S" port)))
1655 0 : (items (apply #'auth-source-macos-keychain-search-items
1656 0 : coll
1657 0 : type
1658 0 : max
1659 0 : host port
1660 0 : search-spec)))
1661 0 : (when items
1662 0 : (throw 'match items)))))))
1663 :
1664 : ;; ensure each item has each key in `returned-keys'
1665 0 : (items (mapcar (lambda (plist)
1666 0 : (append
1667 0 : (apply #'append
1668 0 : (mapcar (lambda (req)
1669 0 : (if (plist-get plist req)
1670 : nil
1671 0 : (list req nil)))
1672 0 : returned-keys))
1673 0 : plist))
1674 0 : items)))
1675 0 : items))
1676 :
1677 :
1678 : (defun auth-source--decode-octal-string (string)
1679 : "Convert octal string to utf-8 string. E.g: 'a\134b' to 'a\b'"
1680 0 : (let ((list (string-to-list string))
1681 0 : (size (length string)))
1682 0 : (decode-coding-string
1683 0 : (apply #'unibyte-string
1684 0 : (cl-loop for i = 0 then (+ i (if (eq (nth i list) ?\\) 4 1))
1685 0 : for var = (nth i list)
1686 0 : while (< i size)
1687 0 : if (eq var ?\\)
1688 0 : collect (string-to-number
1689 0 : (concat (cl-subseq list (+ i 1) (+ i 4))) 8)
1690 : else
1691 0 : collect var))
1692 0 : 'utf-8)))
1693 :
1694 : (cl-defun auth-source-macos-keychain-search-items (coll _type _max host port
1695 : &key label type user
1696 : &allow-other-keys)
1697 0 : (let* ((keychain-generic (eq type 'macos-keychain-generic))
1698 0 : (args `(,(if keychain-generic
1699 : "find-generic-password"
1700 0 : "find-internet-password")
1701 0 : "-g"))
1702 0 : (ret (list :type type)))
1703 0 : (when label
1704 0 : (setq args (append args (list "-l" label))))
1705 0 : (when host
1706 0 : (setq args (append args (list (if keychain-generic "-c" "-s") host))))
1707 0 : (when user
1708 0 : (setq args (append args (list "-a" user))))
1709 :
1710 0 : (when port
1711 0 : (if keychain-generic
1712 0 : (setq args (append args (list "-s" port)))
1713 0 : (setq args (append args (list
1714 0 : (if (string-match "[0-9]+" port) "-P" "-r")
1715 0 : port)))))
1716 :
1717 0 : (unless (equal coll "default")
1718 0 : (setq args (append args (list coll))))
1719 :
1720 0 : (with-temp-buffer
1721 0 : (apply #'call-process "/usr/bin/security" nil t nil args)
1722 0 : (goto-char (point-min))
1723 0 : (while (not (eobp))
1724 0 : (cond
1725 0 : ((looking-at "^password: \\(?:0x[0-9A-F]+\\)? *\"\\(.+\\)\"")
1726 0 : (setq ret (auth-source-macos-keychain-result-append
1727 0 : ret
1728 0 : keychain-generic
1729 : "secret"
1730 0 : (let ((v (auth-source--decode-octal-string
1731 0 : (match-string 1))))
1732 0 : (lambda () v)))))
1733 : ;; TODO: check if this is really the label
1734 : ;; match 0x00000007 <blob>="AppleID"
1735 0 : ((looking-at
1736 0 : "^[ ]+0x00000007 <blob>=\\(?:0x[0-9A-F]+\\)? *\"\\(.+\\)\"")
1737 0 : (setq ret (auth-source-macos-keychain-result-append
1738 0 : ret
1739 0 : keychain-generic
1740 : "label"
1741 0 : (auth-source--decode-octal-string (match-string 1)))))
1742 : ;; match "crtr"<uint32>="aapl"
1743 : ;; match "svce"<blob>="AppleID"
1744 0 : ((looking-at
1745 0 : "^[ ]+\"\\([a-z]+\\)\"[^=]+=\\(?:0x[0-9A-F]+\\)? *\"\\(.+\\)\"")
1746 0 : (setq ret (auth-source-macos-keychain-result-append
1747 0 : ret
1748 0 : keychain-generic
1749 0 : (auth-source--decode-octal-string (match-string 1))
1750 0 : (auth-source--decode-octal-string (match-string 2))))))
1751 0 : (forward-line)))
1752 : ;; return `ret' iff it has the :secret key
1753 0 : (and (plist-get ret :secret) (list ret))))
1754 :
1755 : (defun auth-source-macos-keychain-result-append (result generic k v)
1756 0 : (push v result)
1757 0 : (push (auth-source--symbol-keyword
1758 0 : (cond
1759 0 : ((equal k "acct") "user")
1760 : ;; for generic keychains, creator is host, service is port
1761 0 : ((and generic (equal k "crtr")) "host")
1762 0 : ((and generic (equal k "svce")) "port")
1763 : ;; for internet keychains, protocol is port, server is host
1764 0 : ((and (not generic) (equal k "ptcl")) "port")
1765 0 : ((and (not generic) (equal k "srvr")) "host")
1766 0 : (t k)))
1767 0 : result))
1768 :
1769 : (defun auth-source-macos-keychain-create (&rest spec)
1770 : ;; TODO
1771 0 : (debug spec))
1772 :
1773 : ;;; Backend specific parsing: PLSTORE backend
1774 :
1775 : (cl-defun auth-source-plstore-search (&rest spec
1776 : &key backend create delete max
1777 : &allow-other-keys)
1778 : "Search the PLSTORE; spec is like `auth-source'."
1779 0 : (let* ((store (oref backend data))
1780 0 : (max (or max 5000)) ; sanity check: default to stop at 5K
1781 : (ignored-keys '(:create :delete :max :backend :label :require :type))
1782 0 : (search-keys (cl-loop for i below (length spec) by 2
1783 0 : unless (memq (nth i spec) ignored-keys)
1784 0 : collect (nth i spec)))
1785 : ;; build a search spec without the ignored keys
1786 : ;; if a search key is nil or t (match anything), we skip it
1787 0 : (search-spec (apply #'append (mapcar
1788 : (lambda (k)
1789 0 : (let ((v (plist-get spec k)))
1790 0 : (if (or (null v)
1791 0 : (eq t v))
1792 : nil
1793 0 : (if (stringp v)
1794 0 : (setq v (list v)))
1795 0 : (list k v))))
1796 0 : search-keys)))
1797 : ;; needed keys (always including host, login, port, and secret)
1798 0 : (returned-keys (delete-dups (append
1799 : '(:host :login :port :secret)
1800 0 : search-keys)))
1801 0 : (items (plstore-find store search-spec))
1802 0 : (item-names (mapcar #'car items))
1803 0 : (items (butlast items (- (length items) max)))
1804 : ;; convert the item to a full plist
1805 0 : (items (mapcar (lambda (item)
1806 0 : (let* ((plist (copy-tree (cdr item)))
1807 0 : (secret (plist-member plist :secret)))
1808 0 : (if secret
1809 0 : (setcar
1810 0 : (cdr secret)
1811 0 : (let ((v (car (cdr secret))))
1812 0 : (lambda () v))))
1813 0 : plist))
1814 0 : items))
1815 : ;; ensure each item has each key in `returned-keys'
1816 0 : (items (mapcar (lambda (plist)
1817 0 : (append
1818 0 : (apply #'append
1819 0 : (mapcar (lambda (req)
1820 0 : (if (plist-get plist req)
1821 : nil
1822 0 : (list req nil)))
1823 0 : returned-keys))
1824 0 : plist))
1825 0 : items)))
1826 0 : (cond
1827 : ;; if we need to create an entry AND none were found to match
1828 0 : ((and create
1829 0 : (not items))
1830 :
1831 : ;; create based on the spec and record the value
1832 0 : (setq items (or
1833 : ;; if the user did not want to create the entry
1834 : ;; in the file, it will be returned
1835 0 : (apply (slot-value backend 'create-function) spec)
1836 : ;; if not, we do the search again without :create
1837 : ;; to get the updated data.
1838 :
1839 : ;; the result will be returned, even if the search fails
1840 0 : (apply #'auth-source-plstore-search
1841 0 : (plist-put spec :create nil)))))
1842 0 : ((and delete
1843 0 : item-names)
1844 0 : (dolist (item-name item-names)
1845 0 : (plstore-delete store item-name))
1846 0 : (plstore-save store)))
1847 0 : items))
1848 :
1849 : (cl-defun auth-source-plstore-create (&rest spec
1850 : &key backend host port create
1851 : &allow-other-keys)
1852 0 : (let* ((base-required '(host user port secret))
1853 : (base-secret '(secret))
1854 : ;; we know (because of an assertion in auth-source-search) that the
1855 : ;; :create parameter is either t or a list (which includes nil)
1856 0 : (create-extra (if (eq t create) nil create))
1857 0 : (current-data (car (auth-source-search :max 1
1858 0 : :host host
1859 0 : :port port)))
1860 0 : (required (append base-required create-extra))
1861 : ;; `valist' is an alist
1862 : valist
1863 : ;; `artificial' will be returned if no creation is needed
1864 : artificial
1865 : secret-artificial)
1866 :
1867 : ;; only for base required elements (defined as function parameters):
1868 : ;; fill in the valist with whatever data we may have from the search
1869 : ;; we complete the first value if it's a list and use the value otherwise
1870 0 : (dolist (br base-required)
1871 0 : (let ((val (plist-get spec (auth-source--symbol-keyword br))))
1872 0 : (when val
1873 0 : (let ((br-choice (cond
1874 : ;; all-accepting choice (predicate is t)
1875 0 : ((eq t val) nil)
1876 : ;; just the value otherwise
1877 0 : (t val))))
1878 0 : (when br-choice
1879 0 : (auth-source--aput valist br br-choice))))))
1880 :
1881 : ;; for extra required elements, see if the spec includes a value for them
1882 0 : (dolist (er create-extra)
1883 0 : (let ((k (auth-source--symbol-keyword er))
1884 0 : (keys (cl-loop for i below (length spec) by 2
1885 0 : collect (nth i spec))))
1886 0 : (when (memq k keys)
1887 0 : (auth-source--aput valist er (plist-get spec k)))))
1888 :
1889 : ;; for each required element
1890 0 : (dolist (r required)
1891 0 : (let* ((data (auth-source--aget valist r))
1892 : ;; take the first element if the data is a list
1893 0 : (data (or (auth-source-netrc-element-or-first data)
1894 0 : (plist-get current-data
1895 0 : (auth-source--symbol-keyword r))))
1896 : ;; this is the default to be offered
1897 0 : (given-default (auth-source--aget
1898 0 : auth-source-creation-defaults r))
1899 : ;; the default supplementals are simple:
1900 : ;; for the user, try `given-default' and then (user-login-name);
1901 : ;; otherwise take `given-default'
1902 0 : (default (cond
1903 0 : ((and (not given-default) (eq r 'user))
1904 0 : (user-login-name))
1905 0 : (t given-default)))
1906 0 : (printable-defaults (list
1907 0 : (cons 'user
1908 0 : (or
1909 0 : (auth-source-netrc-element-or-first
1910 0 : (auth-source--aget valist 'user))
1911 0 : (plist-get artificial :user)
1912 0 : "[any user]"))
1913 0 : (cons 'host
1914 0 : (or
1915 0 : (auth-source-netrc-element-or-first
1916 0 : (auth-source--aget valist 'host))
1917 0 : (plist-get artificial :host)
1918 0 : "[any host]"))
1919 0 : (cons 'port
1920 0 : (or
1921 0 : (auth-source-netrc-element-or-first
1922 0 : (auth-source--aget valist 'port))
1923 0 : (plist-get artificial :port)
1924 0 : "[any port]"))))
1925 0 : (prompt (or (auth-source--aget auth-source-creation-prompts r)
1926 0 : (cl-case r
1927 : (secret "%p password for %u@%h: ")
1928 : (user "%p user name for %h: ")
1929 : (host "%p host name for user %u: ")
1930 0 : (port "%p port for %u@%h: "))
1931 0 : (format "Enter %s (%%u@%%h:%%p): " r)))
1932 0 : (prompt (auth-source-format-prompt
1933 0 : prompt
1934 0 : `((?u ,(auth-source--aget printable-defaults 'user))
1935 0 : (?h ,(auth-source--aget printable-defaults 'host))
1936 0 : (?p ,(auth-source--aget printable-defaults 'port))))))
1937 :
1938 : ;; Store the data, prompting for the password if needed.
1939 0 : (setq data (or data
1940 0 : (if (eq r 'secret)
1941 0 : (or (eval default) (read-passwd prompt))
1942 0 : (if (stringp default)
1943 0 : (read-string
1944 0 : (if (string-match ": *\\'" prompt)
1945 0 : (concat (substring prompt 0 (match-beginning 0))
1946 0 : " (default " default "): ")
1947 0 : (concat prompt "(default " default ") "))
1948 0 : nil nil default)
1949 0 : (eval default)))))
1950 :
1951 0 : (when data
1952 0 : (if (member r base-secret)
1953 0 : (setq secret-artificial
1954 0 : (plist-put secret-artificial
1955 0 : (auth-source--symbol-keyword r)
1956 0 : data))
1957 0 : (setq artificial (plist-put artificial
1958 0 : (auth-source--symbol-keyword r)
1959 0 : data))))))
1960 0 : (plstore-put (oref backend data)
1961 0 : (sha1 (format "%s@%s:%s"
1962 0 : (plist-get artificial :user)
1963 0 : (plist-get artificial :host)
1964 0 : (plist-get artificial :port)))
1965 0 : artificial secret-artificial)
1966 0 : (if (y-or-n-p (format "Save auth info to file %s? "
1967 0 : (plstore-get-file (oref backend data))))
1968 0 : (plstore-save (oref backend data)))))
1969 :
1970 : ;;; older API
1971 :
1972 : ;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" t "tzz")
1973 :
1974 : ;; deprecate the old interface
1975 : (make-obsolete 'auth-source-user-or-password
1976 : 'auth-source-search "Emacs 24.1")
1977 : (make-obsolete 'auth-source-forget-user-or-password
1978 : 'auth-source-forget "Emacs 24.1")
1979 :
1980 : (defun auth-source-user-or-password
1981 : (mode host port &optional username create-missing delete-existing)
1982 : "Find MODE (string or list of strings) matching HOST and PORT.
1983 :
1984 : DEPRECATED in favor of `auth-source-search'!
1985 :
1986 : USERNAME is optional and will be used as \"login\" in a search
1987 : across the Secret Service API (see secrets.el) if the resulting
1988 : items don't have a username. This means that if you search for
1989 : username \"joe\" and it matches an item but the item doesn't have
1990 : a :user attribute, the username \"joe\" will be returned.
1991 :
1992 : A non nil DELETE-EXISTING means deleting any matching password
1993 : entry in the respective sources. This is useful only when
1994 : CREATE-MISSING is non nil as well; the intended use case is to
1995 : remove wrong password entries.
1996 :
1997 : If no matching entry is found, and CREATE-MISSING is non nil,
1998 : the password will be retrieved interactively, and it will be
1999 : stored in the password database which matches best (see
2000 : `auth-sources').
2001 :
2002 : MODE can be \"login\" or \"password\"."
2003 0 : (auth-source-do-debug
2004 : "auth-source-user-or-password: DEPRECATED get %s for %s (%s) + user=%s"
2005 0 : mode host port username)
2006 :
2007 0 : (let* ((listy (listp mode))
2008 0 : (mode (if listy mode (list mode)))
2009 : ;; (cname (if username
2010 : ;; (format "%s %s:%s %s" mode host port username)
2011 : ;; (format "%s %s:%s" mode host port)))
2012 0 : (search (list :host host :port port))
2013 0 : (search (if username (append search (list :user username)) search))
2014 0 : (search (if create-missing
2015 0 : (append search (list :create t))
2016 0 : search))
2017 0 : (search (if delete-existing
2018 0 : (append search (list :delete t))
2019 0 : search))
2020 : ;; (found (if (not delete-existing)
2021 : ;; (gethash cname auth-source-cache)
2022 : ;; (remhash cname auth-source-cache)
2023 : ;; nil)))
2024 : (found nil))
2025 0 : (if found
2026 0 : (progn
2027 0 : (auth-source-do-debug
2028 : "auth-source-user-or-password: DEPRECATED cached %s=%s for %s (%s) + %s"
2029 0 : mode
2030 : ;; don't show the password
2031 0 : (if (and (member "password" mode) t)
2032 : "SECRET"
2033 0 : found)
2034 0 : host port username)
2035 0 : found) ; return the found data
2036 : ;; else, if not found, search with a max of 1
2037 0 : (let ((choice (nth 0 (apply #'auth-source-search
2038 0 : (append '(:max 1) search)))))
2039 0 : (when choice
2040 0 : (dolist (m mode)
2041 0 : (cond
2042 0 : ((equal "password" m)
2043 0 : (push (if (plist-get choice :secret)
2044 0 : (funcall (plist-get choice :secret))
2045 0 : nil) found))
2046 0 : ((equal "login" m)
2047 0 : (push (plist-get choice :user) found)))))
2048 0 : (setq found (nreverse found))
2049 0 : (setq found (if listy found (car-safe found)))))
2050 :
2051 0 : found))
2052 :
2053 : (defun auth-source-user-and-password (host &optional user)
2054 0 : (let* ((auth-info (car
2055 0 : (if user
2056 0 : (auth-source-search
2057 0 : :host host
2058 0 : :user user
2059 : :max 1
2060 : :require '(:user :secret)
2061 0 : :create nil)
2062 0 : (auth-source-search
2063 0 : :host host
2064 : :max 1
2065 : :require '(:user :secret)
2066 0 : :create nil))))
2067 0 : (user (plist-get auth-info :user))
2068 0 : (password (plist-get auth-info :secret)))
2069 0 : (when (functionp password)
2070 0 : (setq password (funcall password)))
2071 0 : (list user password auth-info)))
2072 :
2073 : (provide 'auth-source)
2074 :
2075 : ;;; auth-source.el ends here
|