cgit.sxemacs.org Git - gnus/blob - lisp/auth-source.el

   1 ;;; auth-source.el --- authentication sources for Gnus and Emacs
   2
   3 ;; Copyright (C) 2008-2011 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 'gnus-util)
  43 (require 'netrc)
  44
  45 (eval-when-compile (require 'cl))
  46 (autoload 'secrets-create-item "secrets")
  47 (autoload 'secrets-delete-item "secrets")
  48 (autoload 'secrets-get-alias "secrets")
  49 (autoload 'secrets-get-attribute "secrets")
  50 (autoload 'secrets-get-secret "secrets")
  51 (autoload 'secrets-list-collections "secrets")
  52 (autoload 'secrets-search-items "secrets")
  53
  54 (defgroup auth-source nil
  55   "Authentication sources."
  56   :version "23.1" ;; No Gnus
  57   :group 'gnus)
  58
  59 (defcustom auth-source-protocols '((imap "imap" "imaps" "143" "993")
  60                                    (pop3 "pop3" "pop" "pop3s" "110" "995")
  61                                    (ssh  "ssh" "22")
  62                                    (sftp "sftp" "115")
  63                                    (smtp "smtp" "25"))
  64   "List of authentication protocols and their names"
  65
  66   :group 'auth-source
  67   :version "23.2" ;; No Gnus
  68   :type '(repeat :tag "Authentication Protocols"
  69                  (cons :tag "Protocol Entry"
  70                        (symbol :tag "Protocol")
  71                        (repeat :tag "Names"
  72                                (string :tag "Name")))))
  73
  74 ;;; generate all the protocols in a format Customize can use
  75 ;;; TODO: generate on the fly from auth-source-protocols
  76 (defconst auth-source-protocols-customize
  77   (mapcar (lambda (a)
  78             (let ((p (car-safe a)))
  79               (list 'const
  80                     :tag (upcase (symbol-name p))
  81                     p)))
  82           auth-source-protocols))
  83
  84 (defvar auth-source-cache (make-hash-table :test 'equal)
  85   "Cache for auth-source data")
  86
  87 (defcustom auth-source-do-cache t
  88   "Whether auth-source should cache information."
  89   :group 'auth-source
  90   :version "23.2" ;; No Gnus
  91   :type `boolean)
  92
  93 (defcustom auth-source-debug nil
  94   "Whether auth-source should log debug messages.
  95 Also see `auth-source-hide-passwords'.
  96
  97 If the value is nil, debug messages are not logged.
  98 If the value is t, debug messages are logged with `message'.
  99  In that case, your authentication data will be in the
 100  clear (except for passwords, which are always stripped out).
 101 If the value is a function, debug messages are logged by calling
 102  that function using the same arguments as `message'."
 103   :group 'auth-source
 104   :version "23.2" ;; No Gnus
 105   :type `(choice
 106           :tag "auth-source debugging mode"
 107           (const :tag "Log using `message' to the *Messages* buffer" t)
 108           (function :tag "Function that takes arguments like `message'")
 109           (const :tag "Don't log anything" nil)))
 110
 111 (defcustom auth-source-hide-passwords t
 112   "Whether auth-source should hide passwords in log messages.
 113 Only relevant if `auth-source-debug' is not nil."
 114   :group 'auth-source
 115   :version "23.2" ;; No Gnus
 116   :type `boolean)
 117
 118 (defcustom auth-sources '((:source "~/.authinfo.gpg")
 119                           (:source "~/.authinfo"))
 120   "List of authentication sources.
 121
 122 The default will get login and password information from a .gpg
 123 file, which you should set up with the EPA/EPG packages to be
 124 encrypted.  See the auth.info manual for details.
 125
 126 Each entry is the authentication type with optional properties.
 127
 128 It's best to customize this with `M-x customize-variable' because the choices
 129 can get pretty complex."
 130   :group 'auth-source
 131   :version "23.2" ;; No Gnus
 132   :type `(repeat :tag "Authentication Sources"
 133                  (list :tag "Source definition"
 134                        (const :format "" :value :source)
 135                        (choice :tag "Authentication backend choice"
 136                                (string :tag "Authentication Source (file)")
 137                                (list :tag "secrets.el (Secret Service API/KWallet/GNOME Keyring)"
 138                                      (const :format "" :value :secrets)
 139                                      (choice :tag "Collection to use"
 140                                              (string :tag "Collection name")
 141                                              (const :tag "Default" 'default)
 142                                              (const :tag "Login" "login")
 143                                              (const :tag "Temporary" "session"))))
 144                        (repeat :tag "Extra Parameters" :inline t
 145                                (choice :tag "Extra parameter"
 146                                        (list :tag "Host (omit to match as a fallback)"
 147                                              (const :format "" :value :host)
 148                                              (choice :tag "Host (machine) choice"
 149                                                      (const :tag "Any" t)
 150                                                      (regexp :tag "Host (machine) regular expression")))
 151                                        (list :tag "Protocol (omit to match as a fallback)"
 152                                              (const :format "" :value :protocol)
 153                                              (choice :tag "Protocol"
 154                                                      (const :tag "Any" t)
 155                                                      ,@auth-source-protocols-customize))
 156                                        (list :tag "User  (omit to match as a fallback)" :inline t
 157                                              (const :format "" :value :user)
 158                                              (choice :tag "Personality or username"
 159                                                      (const :tag "Any" t)
 160                                                      (string :tag "Specific user name"))))))))
 161
 162 (defcustom auth-source-gpg-encrypt-to t
 163   "List of recipient keys that `authinfo.gpg' encrypted to.
 164 If the value is not a list, symmetric encryption will be used."
 165   :group 'auth-source
 166   :version "23.2" ;; No Gnus
 167   :type '(choice (const :tag "Symmetric encryption" t)
 168                  (repeat :tag "Recipient public keys"
 169                          (string :tag "Recipient public key"))))
 170
 171 ;; temp for debugging
 172 ;; (unintern 'auth-source-protocols)
 173 ;; (unintern 'auth-sources)
 174 ;; (customize-variable 'auth-sources)
 175 ;; (setq auth-sources nil)
 176 ;; (format "%S" auth-sources)
 177 ;; (customize-variable 'auth-source-protocols)
 178 ;; (setq auth-source-protocols nil)
 179 ;; (format "%S" auth-source-protocols)
 180 ;; (auth-source-pick nil :host "a" :port 'imap)
 181 ;; (auth-source-user-or-password "login" "imap.myhost.com" 'imap)
 182 ;; (auth-source-user-or-password "password" "imap.myhost.com" 'imap)
 183 ;; (auth-source-user-or-password-imap "login" "imap.myhost.com")
 184 ;; (auth-source-user-or-password-imap "password" "imap.myhost.com")
 185 ;; (auth-source-protocol-defaults 'imap)
 186
 187 ;; (let ((auth-source-debug 'debug)) (auth-source-debug "hello"))
 188 ;; (let ((auth-source-debug t)) (auth-source-debug "hello"))
 189 ;; (let ((auth-source-debug nil)) (auth-source-debug "hello"))
 190 (defun auth-source-do-debug (&rest msg)
 191   ;; set logger to either the function in auth-source-debug or 'message
 192   ;; note that it will be 'message if auth-source-debug is nil, so
 193   ;; we also check the value
 194   (when auth-source-debug
 195     (let ((logger (if (functionp auth-source-debug)
 196                       auth-source-debug
 197                     'message)))
 198       (apply logger msg))))
 199
 200 ;; (auth-source-pick nil :host "any" :protocol 'imap :user "joe")
 201 ;; (auth-source-pick t :host "any" :protocol 'imap :user "joe")
 202 ;; (setq auth-sources '((:source (:secrets default) :host t :protocol t :user "joe")
 203 ;;                   (:source (:secrets "session") :host t :protocol t :user "joe")
 204 ;;                   (:source (:secrets "login") :host t :protocol t)
 205 ;;                   (:source "~/.authinfo.gpg" :host t :protocol t)))
 206
 207 ;; (setq auth-sources '((:source (:secrets default) :host t :protocol t :user "joe")
 208 ;;                   (:source (:secrets "session") :host t :protocol t :user "joe")
 209 ;;                   (:source (:secrets "login") :host t :protocol t)
 210 ;;                   ))
 211
 212 ;; (setq auth-sources '((:source "~/.authinfo.gpg" :host t :protocol t)))
 213
 214 (defun auth-get-source (entry)
 215   "Return the source string of ENTRY, which is one entry in `auth-sources'.
 216 If it is a Secret Service API, return the collection name, otherwise
 217 the file name."
 218   (let ((source (plist-get entry :source)))
 219     (if (stringp source)
 220         source
 221       ;; Secret Service API.
 222       (setq source (plist-get source :secrets))
 223       (when (eq source 'default)
 224         (setq source (or (secrets-get-alias "default") "login")))
 225       (or source "session"))))
 226
 227 (defun auth-source-pick (&rest spec)
 228   "Parse `auth-sources' for matches of the SPEC plist.
 229
 230 Common keys are :host, :protocol, and :user.  A value of t in
 231 SPEC means to always succeed in the match.  A string value is
 232 matched as a regex."
 233   (let ((keys (loop for i below (length spec) by 2 collect (nth i spec)))
 234         choices)
 235     (dolist (choice (copy-tree auth-sources) choices)
 236       (let ((source (plist-get choice :source))
 237             (match t))
 238         (when
 239             (and
 240              ;; Check existence of source.
 241              (if (consp source)
 242                  ;; Secret Service API.
 243                  (member (auth-get-source choice) (secrets-list-collections))
 244                ;; authinfo file.
 245                (file-exists-p source))
 246
 247              ;; Check keywords.
 248              (dolist (k keys match)
 249                (let* ((v (plist-get spec k))
 250                       (choicev (if (plist-member choice k)
 251                                    (plist-get choice k) t)))
 252                  (setq match
 253                        (and match
 254                             (or
 255                              ;; source always matches spec key
 256                              (eq t choicev)
 257                              ;; source key gives regex to match against spec
 258                              (and (stringp choicev) (string-match choicev v))
 259                              ;; source key gives symbol to match against spec
 260                              (and (symbolp choicev) (eq choicev v))))))))
 261
 262           (add-to-list 'choices choice 'append))))))
 263
 264 (defun auth-source-retrieve (mode entry &rest spec)
 265   "Retrieve MODE credentials according to SPEC from ENTRY."
 266   (catch 'no-password
 267     (let ((host (plist-get spec :host))
 268           (user (plist-get spec :user))
 269           (prot (plist-get spec :protocol))
 270           (source (plist-get entry :source))
 271           result)
 272       (cond
 273        ;; Secret Service API.
 274        ((consp source)
 275         (let ((coll (auth-get-source entry))
 276               item)
 277           ;; Loop over candidates with a matching host attribute.
 278           (dolist (elt (secrets-search-items coll :host host) item)
 279             (when (and (or (not user)
 280                            (string-equal
 281                             user (secrets-get-attribute coll elt :user)))
 282                        (or (not prot)
 283                            (string-equal
 284                             prot (secrets-get-attribute coll elt :protocol))))
 285               (setq item elt)
 286               (return elt)))
 287           ;; Compose result.
 288           (when item
 289             (setq result
 290                   (mapcar (lambda (m)
 291                             (if (string-equal "password" m)
 292                                 (or (secrets-get-secret coll item)
 293                                     ;; When we do not find a password,
 294                                     ;; we return nil anyway.
 295                                     (throw 'no-password nil))
 296                               (or (secrets-get-attribute coll item :user)
 297                                   user)))
 298                           (if (consp mode) mode (list mode)))))
 299           (if (consp mode) result (car result))))
 300        ;; Anything else is netrc.
 301        (t
 302         (let ((search (list source (list host) (list (format "%s" prot))
 303                             (auth-source-protocol-defaults prot))))
 304           (setq result
 305                 (mapcar (lambda (m)
 306                           (if (string-equal "password" m)
 307                               (or (apply
 308                                    'netrc-machine-user-or-password m search)
 309                                   ;; When we do not find a password, we
 310                                   ;; return nil anyway.
 311                                   (throw 'no-password nil))
 312                             (or (apply
 313                                  'netrc-machine-user-or-password m search)
 314                                 user)))
 315                         (if (consp mode) mode (list mode)))))
 316         (if (consp mode) result (car result)))))))
 317
 318 (defun auth-source-create (mode entry &rest spec)
 319   "Create interactively credentials according to SPEC in ENTRY.
 320 Return structure as specified by MODE."
 321   (let* ((host (plist-get spec :host))
 322          (user (plist-get spec :user))
 323          (prot (plist-get spec :protocol))
 324          (source (plist-get entry :source))
 325          (name (concat (if user (format "%s@" user))
 326                        host
 327                        (if prot (format ":%s" prot))))
 328          result)
 329     (setq result
 330           (mapcar
 331            (lambda (m)
 332              (cons
 333               m
 334               (cond
 335                ((equal "password" m)
 336                 (let ((passwd (read-passwd
 337                                (format "Password for %s on %s: " prot host))))
 338                   (cond
 339                    ;; Secret Service API.
 340                    ((consp source)
 341                     (apply
 342                      'secrets-create-item
 343                      (auth-get-source entry) name passwd spec))
 344                    (t)) ;; netrc not implemented yes.
 345                   passwd))
 346                ((equal "login" m)
 347                 (or user
 348                     (read-string
 349                      (format "User name for %s on %s (default %s): " prot host
 350                              (user-login-name))
 351                      nil nil (user-login-name))))
 352                (t
 353                 "unknownuser"))))
 354            (if (consp mode) mode (list mode))))
 355     ;; Allow the source to save the data.
 356     (cond
 357      ((consp source)
 358       ;; Secret Service API -- not implemented.
 359       )
 360      (t
 361       ;; netrc interface.
 362       (when (y-or-n-p (format "Do you want to save this password in %s? "
 363                               source))
 364         ;; the code below is almost same as `netrc-store-data' except
 365         ;; the `epa-file-encrypt-to' hack (see bug#7487).
 366         (with-temp-buffer
 367           (when (file-exists-p source)
 368             (insert-file-contents source))
 369           (when auth-source-gpg-encrypt-to
 370             ;; making `epa-file-encrypt-to' local to this buffer lets
 371             ;; epa-file skip the key selection query (see the
 372             ;; `local-variable-p' check in `epa-file-write-region').
 373             (unless (local-variable-p 'epa-file-encrypt-to (current-buffer))
 374               (make-local-variable 'epa-file-encrypt-to))
 375             (if (listp auth-source-gpg-encrypt-to)
 376                 (setq epa-file-encrypt-to auth-source-gpg-encrypt-to)))
 377           (goto-char (point-max))
 378           (unless (bolp)
 379             (insert "\n"))
 380           (insert (format "machine %s login %s password %s port %s\n"
 381                           host
 382                           (or user (cdr (assoc "login" result)))
 383                           (cdr (assoc "password" result))
 384                           prot))
 385           (write-region (point-min) (point-max) source nil 'silent)))))
 386     (if (consp mode)
 387         (mapcar #'cdr result)
 388       (cdar result))))
 389
 390 (defun auth-source-delete (entry &rest spec)
 391   "Delete credentials according to SPEC in ENTRY."
 392   (let ((host (plist-get spec :host))
 393         (user (plist-get spec :user))
 394         (prot (plist-get spec :protocol))
 395         (source (plist-get entry :source)))
 396     (cond
 397      ;; Secret Service API.
 398      ((consp source)
 399       (let ((coll (auth-get-source entry)))
 400         ;; Loop over candidates with a matching host attribute.
 401         (dolist (elt (secrets-search-items coll :host host))
 402           (when (and (or (not user)
 403                          (string-equal
 404                           user (secrets-get-attribute coll elt :user)))
 405                      (or (not prot)
 406                          (string-equal
 407                           prot (secrets-get-attribute coll elt :protocol))))
 408             (secrets-delete-item coll elt)))))
 409      (t)))) ;; netrc not implemented yes.
 410
 411 (defun auth-source-forget-user-or-password
 412   (mode host protocol &optional username)
 413   "Remove cached authentication token."
 414   (interactive "slogin/password: \nsHost: \nsProtocol: \n") ;for testing
 415   (remhash
 416    (if username
 417        (format "%s %s:%s %s" mode host protocol username)
 418      (format "%s %s:%s" mode host protocol))
 419    auth-source-cache))
 420
 421 (defun auth-source-forget-all-cached ()
 422   "Forget all cached auth-source authentication tokens."
 423   (interactive)
 424   (setq auth-source-cache (make-hash-table :test 'equal)))
 425
 426 ;; (progn
 427 ;;   (auth-source-forget-all-cached)
 428 ;;   (list
 429 ;;    (auth-source-user-or-password '("login" "password") "imap.myhost.com" "other")
 430 ;;    (auth-source-user-or-password '("login" "password") "imap.myhost.com" "other" "tzz")
 431 ;;    (auth-source-user-or-password '("login" "password") "imap.myhost.com" "other" "joe")))
 432
 433 (defun auth-source-user-or-password
 434   (mode host protocol &optional username create-missing delete-existing)
 435   "Find MODE (string or list of strings) matching HOST and PROTOCOL.
 436
 437 USERNAME is optional and will be used as \"login\" in a search
 438 across the Secret Service API (see secrets.el) if the resulting
 439 items don't have a username.  This means that if you search for
 440 username \"joe\" and it matches an item but the item doesn't have
 441 a :user attribute, the username \"joe\" will be returned.
 442
 443 A non nil DELETE-EXISTING means deleting any matching password
 444 entry in the respective sources.  This is useful only when
 445 CREATE-MISSING is non nil as well; the intended use case is to
 446 remove wrong password entries.
 447
 448 If no matching entry is found, and CREATE-MISSING is non nil,
 449 the password will be retrieved interactively, and it will be
 450 stored in the password database which matches best (see
 451 `auth-sources').
 452
 453 MODE can be \"login\" or \"password\"."
 454   (auth-source-do-debug
 455    "auth-source-user-or-password: get %s for %s (%s) + user=%s"
 456    mode host protocol username)
 457   (let* ((listy (listp mode))
 458          (mode (if listy mode (list mode)))
 459          (cname (if username
 460                     (format "%s %s:%s %s" mode host protocol username)
 461                   (format "%s %s:%s" mode host protocol)))
 462          (search (list :host host :protocol protocol))
 463          (search (if username (append search (list :user username)) search))
 464          (found (if (not delete-existing)
 465                     (gethash cname auth-source-cache)
 466                   (remhash cname auth-source-cache)
 467                   nil)))
 468     (if found
 469         (progn
 470           (auth-source-do-debug
 471            "auth-source-user-or-password: cached %s=%s for %s (%s) + %s"
 472            mode
 473            ;; don't show the password
 474            (if (and (member "password" mode) auth-source-hide-passwords)
 475                "SECRET"
 476              found)
 477            host protocol username)
 478           found)                        ; return the found data
 479       ;; else, if not found
 480       (let ((choices (apply 'auth-source-pick search)))
 481         (dolist (choice choices)
 482           (if delete-existing
 483               (apply 'auth-source-delete choice search)
 484             (setq found (apply 'auth-source-retrieve mode choice search)))
 485           (and found (return found)))
 486
 487         ;; We haven't found something, so we will create it interactively.
 488         (when (and (not found) create-missing)
 489           (setq found (apply 'auth-source-create
 490                              mode (if choices
 491                                       (car choices)
 492                                     (car auth-sources))
 493                              search)))
 494
 495         ;; Cache the result.
 496         (when found
 497           (auth-source-do-debug
 498            "auth-source-user-or-password: found %s=%s for %s (%s) + %s"
 499            mode
 500            ;; don't show the password
 501            (if (and (member "password" mode) auth-source-hide-passwords)
 502                "SECRET" found)
 503            host protocol username)
 504           (setq found (if listy found (car-safe found)))
 505           (when auth-source-do-cache
 506             (puthash cname found auth-source-cache)))
 507
 508         found))))
 509
 510 (defun auth-source-protocol-defaults (protocol)
 511   "Return a list of default ports and names for PROTOCOL."
 512   (cdr-safe (assoc protocol auth-source-protocols)))
 513
 514 (defun auth-source-user-or-password-imap (mode host)
 515   (auth-source-user-or-password mode host 'imap))
 516
 517 (defun auth-source-user-or-password-pop3 (mode host)
 518   (auth-source-user-or-password mode host 'pop3))
 519
 520 (defun auth-source-user-or-password-ssh (mode host)
 521   (auth-source-user-or-password mode host 'ssh))
 522
 523 (defun auth-source-user-or-password-sftp (mode host)
 524   (auth-source-user-or-password mode host 'sftp))
 525
 526 (defun auth-source-user-or-password-smtp (mode host)
 527   (auth-source-user-or-password mode host 'smtp))
 528
 529 (provide 'auth-source)
 530
 531 ;;; auth-source.el ends here