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
  42 (defgroup auth-source nil
  43   "Authentication sources."
  44   :version "23.1" ;; No Gnus
  45   :group 'gnus)
  46
  47 (defcustom auth-source-protocols '((imap "imap" "imaps" "143" "993")
  48                                    (pop3 "pop3" "pop" "pop3s" "110" "995")
  49                                    (ssh  "ssh" "22")
  50                                    (sftp "sftp" "115")
  51                                    (smtp "smtp" "25"))
  52   "List of authentication protocols and their names"
  53
  54   :group 'auth-source
  55   :version "23.2" ;; No Gnus
  56   :type '(repeat :tag "Authentication Protocols"
  57                  (cons :tag "Protocol Entry"
  58                        (symbol :tag "Protocol")
  59                        (repeat :tag "Names"
  60                                (string :tag "Name")))))
  61
  62 ;;; generate all the protocols in a format Customize can use
  63 (defconst auth-source-protocols-customize
  64   (mapcar (lambda (a)
  65             (let ((p (car-safe a)))
  66               (list 'const
  67                     :tag (upcase (symbol-name p))
  68                     p)))
  69           auth-source-protocols))
  70
  71 (defvar auth-source-cache (make-hash-table :test 'equal)
  72   "Cache for auth-source data")
  73
  74 (defcustom auth-source-do-cache t
  75   "Whether auth-source should cache information."
  76   :group 'auth-source
  77   :version "23.2" ;; No Gnus
  78   :type `boolean)
  79
  80 (defcustom auth-source-debug nil
  81   "Whether auth-source should log debug messages.
  82 Also see `auth-source-hide-passwords'.
  83
  84 If the value is nil, debug messages are not logged.
  85 If the value is t, debug messages are logged with `message'.
  86  In that case, your authentication data will be in the
  87  clear (except for passwords, which are always stripped out).
  88 If the value is a function, debug messages are logged by calling
  89  that function using the same arguments as `message'."
  90   :group 'auth-source
  91   :version "23.2" ;; No Gnus
  92   :type `(choice
  93           :tag "auth-source debugging mode"
  94           (const :tag "Log using `message' to the *Messages* buffer" t)
  95           (function :tag "Function that takes arguments like `message'")
  96           (const :tag "Don't log anything" nil)))
  97
  98 (defcustom auth-source-hide-passwords t
  99   "Whether auth-source should hide passwords in log messages.
 100 Only relevant if `auth-source-debug' is not nil."
 101   :group 'auth-source
 102   :version "23.2" ;; No Gnus
 103   :type `boolean)
 104
 105 (defcustom auth-sources '((:source "~/.authinfo.gpg" :host t :protocol t))
 106   "List of authentication sources.
 107
 108 Each entry is the authentication type with optional properties.
 109
 110 It's best to customize this with `M-x customize-variable' because the choices
 111 can get pretty complex."
 112   :group 'auth-source
 113   :version "23.2" ;; No Gnus
 114   :type `(repeat :tag "Authentication Sources"
 115                  (list :tag "Source definition"
 116                        (const :format "" :value :source)
 117                        (choice :tag "Authentication backend choice"
 118                                (string :tag "Authentication Source (file)")
 119                                (list :tag "secrets.el (Secret Service API/KWallet/GNOME KeyRing)"
 120                                      (const :format "" :value :secrets)
 121                                      (choice :tag "Collection to use"
 122                                              (string :tag "Collection name")
 123                                              (const :tag "Default" 'default)
 124                                              (const :tag "Any" t)
 125                                              (const :tag "Temporary" "session")
 126                                              (string :tag "Specific session name")
 127                                              (const :tag "Fallback" nil))))
 128                        (const :format "" :value :host)
 129                        (choice :tag "Host (machine) choice"
 130                                (const :tag "Any" t)
 131                                (regexp :tag "Host (machine) regular expression (TODO)")
 132                                (const :tag "Fallback" nil))
 133                        (const :format "" :value :protocol)
 134                        (choice :tag "Protocol"
 135                                (const :tag "Any" t)
 136                                (const :tag "Fallback" nil)
 137                                ,@auth-source-protocols-customize)
 138                        (repeat :tag "Extra Parameters" :inline t
 139                                (choice :tag "Extra parameter"
 140                                        (list :tag "Preferred username" :inline t
 141                                              (const :format "" :value :preferred-username)
 142                                              (choice :tag "Personality or username"
 143                                                      (const :tag "Any" t)
 144                                                      (const :tag "Fallback" nil)
 145                                                      (string :tag "Specific user name"))))))))
 146
 147 ;; temp for debugging
 148 ;; (unintern 'auth-source-protocols)
 149 ;; (unintern 'auth-sources)
 150 ;; (customize-variable 'auth-sources)
 151 ;; (setq auth-sources nil)
 152 ;; (format "%S" auth-sources)
 153 ;; (customize-variable 'auth-source-protocols)
 154 ;; (setq auth-source-protocols nil)
 155 ;; (format "%S" auth-source-protocols)
 156 ;; (auth-source-pick "a" 'imap)
 157 ;; (auth-source-user-or-password "login" "imap.myhost.com" 'imap)
 158 ;; (auth-source-user-or-password "password" "imap.myhost.com" 'imap)
 159 ;; (auth-source-user-or-password-imap "login" "imap.myhost.com")
 160 ;; (auth-source-user-or-password-imap "password" "imap.myhost.com")
 161 ;; (auth-source-protocol-defaults 'imap)
 162
 163 ;; (let ((auth-source-debug 'debug)) (auth-source-debug "hello"))
 164 ;; (let ((auth-source-debug t)) (auth-source-debug "hello"))
 165 ;; (let ((auth-source-debug nil)) (auth-source-debug "hello"))
 166 (defun auth-source-do-debug (&rest msg)
 167   ;; set logger to either the function in auth-source-debug or 'message
 168   ;; note that it will be 'message if auth-source-debug is nil, so
 169   ;; we also check the value
 170   (when auth-source-debug
 171     (let ((logger (if (functionp auth-source-debug)
 172                       auth-source-debug
 173                     'message)))
 174       (apply logger msg))))
 175
 176 (defun auth-source-pick (host protocol &optional fallback)
 177   "Parse `auth-sources' for HOST, and PROTOCOL matches.
 178
 179 Returns fallback choices (where PROTOCOL or HOST are nil) with FALLBACK t."
 180   (interactive "sHost: \nsProtocol: \n") ;for testing
 181   (let (choices)
 182     (dolist (choice auth-sources)
 183       (let ((h (plist-get choice :host))
 184             (p (plist-get choice :protocol)))
 185         (when (and
 186                (or (equal t h)
 187                    (and (stringp h) (string-match h host))
 188                    (and fallback (equal h nil)))
 189                (or (equal t p)
 190                    (and (symbolp p) (equal p protocol))
 191                    (and fallback (equal p nil))))
 192           (push choice choices))))
 193     (if choices
 194         choices
 195       (unless fallback
 196         (auth-source-pick host protocol t)))))
 197
 198 (defun auth-source-forget-user-or-password (mode host protocol)
 199   (interactive "slogin/password: \nsHost: \nsProtocol: \n") ;for testing
 200   (remhash (format "%s %s:%s" mode host protocol) auth-source-cache))
 201
 202 (defun auth-source-forget-all-cached ()
 203   "Forget all cached auth-source authentication tokens."
 204   (interactive)
 205   (setq auth-source-cache (make-hash-table :test 'equal)))
 206
 207 (defun auth-source-user-or-password (mode host protocol)
 208   "Find MODE (string or list of strings) matching HOST and PROTOCOL.
 209 MODE can be \"login\" or \"password\" for example."
 210   (auth-source-do-debug
 211    "auth-source-user-or-password: get %s for %s (%s)"
 212    mode host protocol)
 213   (let* ((listy (listp mode))
 214          (mode (if listy mode (list mode)))
 215          (cname (format "%s %s:%s" mode host protocol))
 216          (found (gethash cname auth-source-cache)))
 217     (if found
 218         (progn
 219           (auth-source-do-debug
 220            "auth-source-user-or-password: cached %s=%s for %s (%s)"
 221            mode
 222            ;; don't show the password
 223            (if (and (member "password" mode) auth-source-hide-passwords) "SECRET" found)
 224            host protocol)
 225           found)
 226       (dolist (choice (auth-source-pick host protocol))
 227         (setq found (netrc-machine-user-or-password
 228                      mode
 229                      (plist-get choice :source)
 230                      (list host)
 231                      (list (format "%s" protocol))
 232                      (auth-source-protocol-defaults protocol)))
 233         (when found
 234           (auth-source-do-debug
 235            "auth-source-user-or-password: found %s=%s for %s (%s)"
 236            mode
 237            ;; don't show the password
 238            (if (and (member "password" mode) auth-source-hide-passwords) "SECRET" found)
 239            host protocol)
 240           (setq found (if listy found (car-safe found)))
 241           (when auth-source-do-cache
 242             (puthash cname found auth-source-cache)))
 243         (return found)))))
 244
 245 (defun auth-source-protocol-defaults (protocol)
 246   "Return a list of default ports and names for PROTOCOL."
 247   (cdr-safe (assoc protocol auth-source-protocols)))
 248
 249 (defun auth-source-user-or-password-imap (mode host)
 250   (auth-source-user-or-password mode host 'imap))
 251
 252 (defun auth-source-user-or-password-pop3 (mode host)
 253   (auth-source-user-or-password mode host 'pop3))
 254
 255 (defun auth-source-user-or-password-ssh (mode host)
 256   (auth-source-user-or-password mode host 'ssh))
 257
 258 (defun auth-source-user-or-password-sftp (mode host)
 259   (auth-source-user-or-password mode host 'sftp))
 260
 261 (defun auth-source-user-or-password-smtp (mode host)
 262   (auth-source-user-or-password mode host 'smtp))
 263
 264 (provide 'auth-source)
 265
 266 ;; arch-tag: ff1afe78-06e9-42c2-b693-e9f922cbe4ab
 267 ;;; auth-source.el ends here