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