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