diff options
Diffstat (limited to 'lisp/gnus/auth-source.el')
| -rw-r--r-- | lisp/gnus/auth-source.el | 150 |
1 files changed, 112 insertions, 38 deletions
diff --git a/lisp/gnus/auth-source.el b/lisp/gnus/auth-source.el index 116d8b4a6a1..f37e0368845 100644 --- a/lisp/gnus/auth-source.el +++ b/lisp/gnus/auth-source.el @@ -1,7 +1,6 @@ ;;; auth-source.el --- authentication sources for Gnus and Emacs -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. +;; Copyright (C) 2008 Free Software Foundation, Inc. ;; Author: Ted Zlatanov <tzz@lifelogs.com> ;; Keywords: news @@ -32,53 +31,128 @@ ;;; Code: (eval-when-compile (require 'cl)) +(eval-when-compile (require 'netrc)) (defgroup auth-source nil "Authentication sources." - :version "22.1" + :version "23.1" ;; No Gnus :group 'gnus) -(defcustom auth-source-choices nil +(defcustom auth-source-protocols '((imap "imap" "imaps" "143" "993") + (pop3 "pop3" "pop" "pop3s" "110" "995") + (ssh "ssh" "22") + (sftp "sftp" "115") + (smtp "smtp" "25")) + "List of authentication protocols and their names" + + :group 'auth-source + :version "23.1" ;; No Gnus + :type '(repeat :tag "Authentication Protocols" + (cons :tag "Protocol Entry" + (symbol :tag "Protocol") + (repeat :tag "Names" + (string :tag "Name"))))) + +;;; generate all the protocols in a format Customize can use +(defconst auth-source-protocols-customize + (mapcar (lambda (a) + (let ((p (car-safe a))) + (list 'const + :tag (upcase (symbol-name p)) + p))) + auth-source-protocols)) + +;;; this default will be changed to ~/.authinfo.gpg +(defcustom auth-sources '((:source "~/.authinfo.enc" :host t :protocol t)) "List of authentication sources. Each entry is the authentication type with optional properties." :group 'auth-source - :type '(repeat :tag "Authentication Sources" - (cons :tag "Source definition" - (group :tag "Select a source" :inline t - (const :format "" :value :source) - (choice :tag "Authentication information" - (const :tag "None" nil) - (file :tag "File"))) - (checklist :tag "Options" :greedy t - (group :inline t - (choice :tag "Choose the hosts" - (group :tag "Select host by name" :inline t - (const :format "" :value :host) - (string :tag "Host name")) - (group :tag "Select host by regular expression" :inline t - (const :format "" :value :host-regex) - (regexp :tag "Host regular expression")) - (group :tag "Use any host" :inline t - (const :format "" :value :host-any) - (const :tag "Any" t)) - (group :tag "Use if no other host matches" :inline t - (const :tag "Fallback" nil)))) - (group :tag "Choose the protocol" :inline t - (const :format "" :value :protocol) - (choice :tag "Protocol" - (const :tag "Any" t) - (const :tag "Fallback (used if no others match)" nil) - (const :tag "IMAP" imap) - (const :tag "POP3" pop3) - (const :tag "SSH" ssh) - (const :tag "SFTP" sftp) - (const :tag "SMTP" smtp))))))) + :version "23.1" ;; No Gnus + :type `(repeat :tag "Authentication Sources" + (list :tag "Source definition" + (const :format "" :value :source) + (string :tag "Authentication Source") + (const :format "" :value :host) + (choice :tag "Host choice" + (const :tag "Any" t) + (regexp :tag "Host regular expression (TODO)") + (const :tag "Fallback" nil)) + (const :format "" :value :protocol) + (choice :tag "Protocol" + (const :tag "Any" t) + (const :tag "Fallback" nil) + ,@auth-source-protocols-customize)))) ;; temp for debugging -;; (customize-variable 'auth-source-choices) -;; (setq auth-source-choices nil) -;; (format "%S" auth-source-choices) +;; (unintern 'auth-source-protocols) +;; (unintern 'auth-sources) +;; (customize-variable 'auth-sources) +;; (setq auth-sources nil) +;; (format "%S" auth-sources) +;; (customize-variable 'auth-source-protocols) +;; (setq auth-source-protocols nil) +;; (format "%S" auth-source-protocols) +;; (auth-source-pick "a" 'imap) +;; (auth-source-user-or-password "login" "imap.myhost.com" 'imap) +;; (auth-source-user-or-password "password" "imap.myhost.com" 'imap) +;; (auth-source-user-or-password-imap "login" "imap.myhost.com") +;; (auth-source-user-or-password-imap "password" "imap.myhost.com") +;; (auth-source-protocol-defaults 'imap) + +(defun auth-source-pick (host protocol &optional fallback) + "Parse `auth-sources' for HOST and PROTOCOL matches. + +Returns fallback choices (where PROTOCOL or HOST are nil) with FALLBACK t." + (interactive "sHost: \nsProtocol: \n") ;for testing + (let (choices) + (dolist (choice auth-sources) + (let ((h (plist-get choice :host)) + (p (plist-get choice :protocol))) + (when (and + (or (equal t h) + (and (stringp h) (string-match h host)) + (and fallback (equal h nil))) + (or (equal t p) + (and (symbolp p) (equal p protocol)) + (and fallback (equal p nil)))) + (push choice choices)))) + (if choices + choices + (unless fallback + (auth-source-pick host protocol t))))) + +(defun auth-source-user-or-password (mode host protocol) + "Find user or password (from the string MODE) matching HOST and PROTOCOL." + (let (found) + (dolist (choice (auth-source-pick host protocol)) + (setq found (netrc-machine-user-or-password + mode + (plist-get choice :source) + (list host) + (list (format "%s" protocol)) + (auth-source-protocol-defaults protocol))) + (when found + (return found))))) + +(defun auth-source-protocol-defaults (protocol) + "Return a list of default ports and names for PROTOCOL." + (cdr-safe (assoc protocol auth-source-protocols))) + +(defun auth-source-user-or-password-imap (mode host) + (auth-source-user-or-password mode host 'imap)) + +(defun auth-source-user-or-password-pop3 (mode host) + (auth-source-user-or-password mode host 'pop3)) + +(defun auth-source-user-or-password-ssh (mode host) + (auth-source-user-or-password mode host 'ssh)) + +(defun auth-source-user-or-password-sftp (mode host) + (auth-source-user-or-password mode host 'sftp)) + +(defun auth-source-user-or-password-smtp (mode host) + (auth-source-user-or-password mode host 'smtp)) (provide 'auth-source) |