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
  36 (eval-when-compile (require 'cl))
  37 (autoload 'netrc-machine-user-or-password "netrc")
  38 (autoload 'secrets-search-items "secrets")
  39 (autoload 'secrets-get-alias "secrets")
  40 (autoload 'secrets-get-attribute "secrets")
  41 (autoload 'secrets-get-secret "secrets")
  42
  43 (defgroup auth-source nil
  44   "Authentication sources."
  45   :version "23.1" ;; No Gnus
  46   :group 'gnus)
  47
  48 (defcustom auth-source-protocols '((imap "imap" "imaps" "143" "993")
  49                                    (pop3 "pop3" "pop" "pop3s" "110" "995")
  50                                    (ssh  "ssh" "22")
  51                                    (sftp "sftp" "115")
  52                                    (smtp "smtp" "25"))
  53   "List of authentication protocols and their names"
  54
  55   :group 'auth-source
  56   :version "23.2" ;; No Gnus
  57   :type '(repeat :tag "Authentication Protocols"
  58                  (cons :tag "Protocol Entry"
  59                        (symbol :tag "Protocol")
  60                        (repeat :tag "Names"
  61                                (string :tag "Name")))))
  62
  63 ;;; generate all the protocols in a format Customize can use
  64 ;;; TODO: generate on the fly from auth-source-protocols
  65 (defconst auth-source-protocols-customize
  66   (mapcar (lambda (a)
  67             (let ((p (car-safe a)))
  68               (list 'const
  69                     :tag (upcase (symbol-name p))
  70                     p)))
  71           auth-source-protocols))
  72
  73 (defvar auth-source-cache (make-hash-table :test 'equal)
  74   "Cache for auth-source data")
  75
  76 (defcustom auth-source-do-cache t
  77   "Whether auth-source should cache information."
  78   :group 'auth-source
  79   :version "23.2" ;; No Gnus
  80   :type `boolean)
  81
  82 (defcustom auth-source-debug nil
  83   "Whether auth-source should log debug messages.
  84 Also see `auth-source-hide-passwords'.
  85
  86 If the value is nil, debug messages are not logged.
  87 If the value is t, debug messages are logged with `message'.
  88  In that case, your authentication data will be in the
  89  clear (except for passwords, which are always stripped out).
  90 If the value is a function, debug messages are logged by calling
  91  that function using the same arguments as `message'."
  92   :group 'auth-source
  93   :version "23.2" ;; No Gnus
  94   :type `(choice
  95           :tag "auth-source debugging mode"
  96           (const :tag "Log using `message' to the *Messages* buffer" t)
  97           (function :tag "Function that takes arguments like `message'")
  98           (const :tag "Don't log anything" nil)))
  99
 100 (defcustom auth-source-hide-passwords t
 101   "Whether auth-source should hide passwords in log messages.
 102 Only relevant if `auth-source-debug' is not nil."
 103   :group 'auth-source
 104   :version "23.2" ;; No Gnus
 105   :type `boolean)
 106
 107 (defcustom auth-sources '((:source "~/.authinfo.gpg"))
 108   "List of authentication sources.
 109
 110 The default will get login and password information from a .gpg
 111 file, which you should set up with the EPA/EPG packages to be
 112 encrypted.  See the auth.info manual for details.
 113
 114 Each entry is the authentication type with optional properties.
 115
 116 It's best to customize this with `M-x customize-variable' because the choices
 117 can get pretty complex."
 118   :group 'auth-source
 119   :version "23.2" ;; No Gnus
 120   :type `(repeat :tag "Authentication Sources"
 121                  (list :tag "Source definition"
 122                        (const :format "" :value :source)
 123                        (choice :tag "Authentication backend choice"
 124                                (string :tag "Authentication Source (file)")
 125                                (list :tag "secrets.el (Secret Service API/KWallet/GNOME KeyRing)"
 126                                      (const :format "" :value :secrets)
 127                                      (choice :tag "Collection to use"
 128                                              (string :tag "Collection name")
 129                                              (const :tag "Default" 'default)
 130                                              (const :tag "Login" "login")
 131                                              (const :tag "Temporary" "session"))))
 132                        (repeat :tag "Extra Parameters" :inline t
 133                                (choice :tag "Extra parameter"
 134                                        (list :tag "Host (omit to match as a fallback)"
 135                                              (const :format "" :value :host)
 136                                              (choice :tag "Host (machine) choice"
 137                                                      (const :tag "Any" t)
 138                                                      (regexp :tag "Host (machine) regular expression")))
 139                                        (list :tag "Protocol (omit to match as a fallback)"
 140                                              (const :format "" :value :protocol)
 141                                              (choice :tag "Protocol"
 142                                                      (const :tag "Any" t)
 143                                                      ,@auth-source-protocols-customize))
 144                                        (list :tag "User  (omit to match as a fallback)" :inline t
 145                                              (const :format "" :value :user)
 146                                              (choice :tag "Personality or username"
 147                                                      (const :tag "Any" t)
 148                                                      (string :tag "Specific user name"))))))))
 149
 150 ;; temp for debugging
 151 ;; (unintern 'auth-source-protocols)
 152 ;; (unintern 'auth-sources)
 153 ;; (customize-variable 'auth-sources)
 154 ;; (setq auth-sources nil)
 155 ;; (format "%S" auth-sources)
 156 ;; (customize-variable 'auth-source-protocols)
 157 ;; (setq auth-source-protocols nil)
 158 ;; (format "%S" auth-source-protocols)
 159 ;; (auth-source-pick nil :host "a" :port 'imap)
 160 ;; (auth-source-user-or-password "login" "imap.myhost.com" 'imap)
 161 ;; (auth-source-user-or-password "password" "imap.myhost.com" 'imap)
 162 ;; (auth-source-user-or-password-imap "login" "imap.myhost.com")
 163 ;; (auth-source-user-or-password-imap "password" "imap.myhost.com")
 164 ;; (auth-source-protocol-defaults 'imap)
 165
 166 ;; (let ((auth-source-debug 'debug)) (auth-source-debug "hello"))
 167 ;; (let ((auth-source-debug t)) (auth-source-debug "hello"))
 168 ;; (let ((auth-source-debug nil)) (auth-source-debug "hello"))
 169 (defun auth-source-do-debug (&rest msg)
 170   ;; set logger to either the function in auth-source-debug or 'message
 171   ;; note that it will be 'message if auth-source-debug is nil, so
 172   ;; we also check the value
 173   (when auth-source-debug
 174     (let ((logger (if (functionp auth-source-debug)
 175                       auth-source-debug
 176                     'message)))
 177       (apply logger msg))))
 178
 179 ;; (auth-source-pick nil :host "any" :protocol 'imap :user "joe")
 180 ;; (auth-source-pick t :host "any" :protocol 'imap :user "joe")
 181 ;; (setq auth-sources '((:source (:secrets default) :host t :protocol t :user "joe")
 182 ;;                   (:source (:secrets "session") :host t :protocol t :user "joe")
 183 ;;                   (:source (:secrets "login") :host t :protocol t)
 184 ;;                   (:source "~/.authinfo.gpg" :host t :protocol t)))
 185
 186 ;; (setq auth-sources '((:source (:secrets default) :host t :protocol t :user "joe")
 187 ;;                   (:source (:secrets "session") :host t :protocol t :user "joe")
 188 ;;                   (:source (:secrets "login") :host t :protocol t)
 189 ;;                   ))
 190
 191 ;; (setq auth-sources '((:source "~/.authinfo.gpg" :host t :protocol t)))
 192
 193 (defun auth-source-pick (&rest spec)
 194   "Parse `auth-sources' for matches of the SPEC plist.
 195
 196 Common keys are :host, :protocol, and :user.  A value of t in
 197 SPEC means to always succeed in the match.  A string value is
 198 matched as a regex.
 199
 200 The first pass skips fallback choices.  If no choices are found
 201 on the first pass, a second pass is made including the fallback
 202 choices.
 203
 204 For string (filename) sources, fallback choices are those where
 205 PROTOCOL or HOST are nil.
 206
 207 For secrets.el collections, the :host and :protocol keys are not
 208 checked for fallback choices."
 209   (let (choices)
 210     (dolist (fallback '(nil t))
 211       (let ((keys (loop for i below (length spec) by 2
 212                         collect (nth i spec)))
 213             (default-session-fallback "login"))
 214         (dolist (choice auth-sources)
 215           (let* ((s (plist-get choice :source))
 216                  ;; this is only set for Secret Service API specs (see secrets.el)
 217                  (coll (plist-get s :secrets))
 218                  (score 0))
 219             (cond
 220              (coll                              ; use secrets.el here
 221               (when (eq coll 'default)
 222                 (setq coll (secrets-get-alias "default"))
 223                 (unless coll
 224                   (auth-source-do-debug
 225                    "No 'default' alias.  Trying collection '%s'."
 226                    default-session-fallback)
 227                   (setq coll default-session-fallback)))
 228               (let* ((coll-search (cond
 229                                    ((stringp coll) coll)
 230
 231                                    ;; when the collection is nil:
 232                                    ;; in fallback mode, accept it as any
 233                                    ;; otherwise, hope to fail
 234                                    ((null coll) (if fallback
 235                                                     nil
 236                                                   " *fallback-fail*"))))
 237                      ;; assemble a search query for secrets-search-items
 238                      ;; in fallback mode, host and protocol are not checked
 239                      (other-search (loop for k
 240                                          in (if fallback
 241                                                 (remove :host
 242                                                         (remove :protocol keys))
 243                                               keys)
 244                                          append (list
 245                                                  k
 246                                                  ;; convert symbols to a string
 247                                                  (let ((v (plist-get spec k)))
 248                                                    (if (stringp v)
 249                                                        v
 250                                                      (prin1-to-string v))))))
 251                      ;; the score is based on how exact the search was,
 252                      ;; plus base score = 1 for any match
 253                      (score (1+ (length other-search)))
 254                      (results (apply 'secrets-search-items
 255                                      coll-search
 256                                      other-search)))
 257                 (auth-source-do-debug
 258                  "auth-source-pick: got items %s in collection '%s' + %s"
 259                  results coll-search other-search)
 260                 ;; put the results in the choices variable
 261                 (dolist (result results)
 262                   (setq choices (cons (list score
 263                                             `(:source secrets
 264                                                       :item ,result
 265                                                       :collection ,coll
 266                                                       :search ,coll-search
 267                                                       ,@other-search))
 268                                       choices)))))
 269              ;; this is any non-secrets spec (currently means a string filename)
 270              (t
 271               (let ((match t))
 272                 (dolist (k keys)
 273                   (let* ((v (plist-get spec k))
 274                          (choicev (plist-get choice k)))
 275                     (setq match
 276                           (and match
 277                                (or (eq t choicev) ; source always matches spec key
 278                                    ;; source key gives regex to match against spec
 279                                    (and (stringp choicev) (string-match choicev v))
 280                                    ;; source key gives symbol to match against spec
 281                                    (and (symbolp choicev) (eq choicev v))
 282                                    ;; in fallback mode, missing source key is OK
 283                                    fallback)))
 284                     (when match (incf score)))) ; increment the score for each match
 285
 286                 ;; now if the whole iteration resulted in a match:
 287                 (when match
 288                   (setq choices (cons (list score choice) choices))))))))
 289         ;; when there were matches, skip the second pass
 290         (when choices (return choices))))
 291
 292       ;; return the results sorted by score
 293       (mapcar 'cadr (sort choices (lambda (x y) (> (car x) (car y)))))))
 294
 295 (defun auth-source-forget-user-or-password (mode host protocol)
 296   (interactive "slogin/password: \nsHost: \nsProtocol: \n") ;for testing
 297   (remhash (format "%s %s:%s" mode host protocol) auth-source-cache))
 298
 299 (defun auth-source-forget-all-cached ()
 300   "Forget all cached auth-source authentication tokens."
 301   (interactive)
 302   (setq auth-source-cache (make-hash-table :test 'equal)))
 303
 304 ;; (progn
 305 ;;   (auth-source-forget-all-cached)
 306 ;;   (list
 307 ;;    (auth-source-user-or-password '("login" "password") "imap.myhost.com" "other")
 308 ;;    (auth-source-user-or-password '("login" "password") "imap.myhost.com" "other" "tzz")
 309 ;;    (auth-source-user-or-password '("login" "password") "imap.myhost.com" "other" "joe")))
 310
 311 (defun auth-source-user-or-password (mode host protocol &optional username)
 312   "Find MODE (string or list of strings) matching HOST and PROTOCOL.
 313
 314 USERNAME is optional and will be used as \"login\" in a search
 315 across the Secret Service API (see secrets.el) if the resulting
 316 items don't have a username.  This means that if you search for
 317 username \"joe\" and it matches an item but the item doesn't have
 318 a :user attribute, the username \"joe\" will be returned.
 319
 320 MODE can be \"login\" or \"password\" for example."
 321   (auth-source-do-debug
 322    "auth-source-user-or-password: get %s for %s (%s) + user=%s"
 323    mode host protocol username)
 324   (let* ((listy (listp mode))
 325          (mode (if listy mode (list mode)))
 326          (extras (when username `(:user ,username)))
 327          (cname (format "%s %s:%s %s" mode host protocol extras))
 328          (search (list :host host :protocol protocol))
 329          (search (if username (append search (list :user username)) search))
 330          (found (gethash cname auth-source-cache)))
 331     (if found
 332         (progn
 333           (auth-source-do-debug
 334            "auth-source-user-or-password: cached %s=%s for %s (%s) + %s"
 335            mode
 336            ;; don't show the password
 337            (if (and (member "password" mode) auth-source-hide-passwords)
 338                "SECRET"
 339              found)
 340            host protocol extras)
 341           found)                        ; return the found data
 342       ;; else, if not found
 343       (dolist (choice (apply 'auth-source-pick search))
 344         (setq found (cond
 345                      ;; the secrets.el spec
 346                      ((eq (plist-get choice :source) 'secrets)
 347                       (let ((coll (plist-get choice :search))
 348                             (item (plist-get choice :item)))
 349                         (mapcar (lambda (m)
 350                                   (if (equal "password" m)
 351                                       (secrets-get-secret coll item)
 352                                     ;; the user name is either
 353                                     (or
 354                                      ;; the secret's attribute :user, or
 355                                      (secrets-get-attribute coll item :user)
 356                                      ;; the originally requested :user
 357                                      username
 358                                      "unknown-user")))
 359                                 mode)))
 360                      (t         ; anything else is netrc
 361                       (netrc-machine-user-or-password
 362                        mode
 363                        (plist-get choice :source)
 364                        (list host)
 365                        (list (format "%s" protocol))
 366                        (auth-source-protocol-defaults protocol)))))
 367         (when found
 368           (auth-source-do-debug
 369            "auth-source-user-or-password: found %s=%s for %s (%s) + %s"
 370            mode
 371            ;; don't show the password
 372            (if (and (member "password" mode) auth-source-hide-passwords) "SECRET" found)
 373            host protocol extras)
 374           (setq found (if listy found (car-safe found)))
 375           (when auth-source-do-cache
 376             (puthash cname found auth-source-cache)))
 377         (return found)))))
 378
 379 (defun auth-source-protocol-defaults (protocol)
 380   "Return a list of default ports and names for PROTOCOL."
 381   (cdr-safe (assoc protocol auth-source-protocols)))
 382
 383 (defun auth-source-user-or-password-imap (mode host)
 384   (auth-source-user-or-password mode host 'imap))
 385
 386 (defun auth-source-user-or-password-pop3 (mode host)
 387   (auth-source-user-or-password mode host 'pop3))
 388
 389 (defun auth-source-user-or-password-ssh (mode host)
 390   (auth-source-user-or-password mode host 'ssh))
 391
 392 (defun auth-source-user-or-password-sftp (mode host)
 393   (auth-source-user-or-password mode host 'sftp))
 394
 395 (defun auth-source-user-or-password-smtp (mode host)
 396   (auth-source-user-or-password mode host 'smtp))
 397
 398 (provide 'auth-source)
 399
 400 ;; arch-tag: ff1afe78-06e9-42c2-b693-e9f922cbe4ab
 401 ;;; auth-source.el ends here