From: Glenn Morris Date: Sun, 2 Dec 2007 21:52:46 +0000 (+0000) Subject: Move here from ../gnus. X-Git-Tag: emacs-pretest-23.0.90~9133 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=369fc5a6265998ababe34519f48732ad7fb335fc;p=emacs.git Move here from ../gnus. --- diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 9038d2b98dc..bec72ccb1f2 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -13,6 +13,9 @@ 2007-12-02 Glenn Morris + * emacs-lisp/bytecomp.el (byte-compile-declare-function): Reverse + branches of if statement. + * emulation/viper-cmd.el (top-level): Don't require advice. Don't load viper-util, viper-keym, viper-mous, viper-macs, viper-ex when compiling. @@ -37,6 +40,9 @@ * emulation/viper.el (top-level): Don't require ring. Don't load viper-init, viper-cmd when compiling. + * net/sasl-cram.el, net/sasl-digest.el, net/sasl-ntlm.el, net/sasl.el: + Move here from gnus/. + 2007-12-02 Karl Fogel Offer option for saveplace to be quiet about loading and saving. diff --git a/lisp/net/sasl-cram.el b/lisp/net/sasl-cram.el new file mode 100644 index 00000000000..32f1e69f81f --- /dev/null +++ b/lisp/net/sasl-cram.el @@ -0,0 +1,52 @@ +;;; sasl-cram.el --- CRAM-MD5 module for the SASL client framework + +;; Copyright (C) 2000, 2007 Free Software Foundation, Inc. + +;; Author: Daiki Ueno +;; Kenichi OKADA +;; Keywords: SASL, CRAM-MD5 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +(require 'sasl) +(require 'hmac-md5) + +(defconst sasl-cram-md5-steps + '(ignore ;no initial response + sasl-cram-md5-response)) + +(defun sasl-cram-md5-response (client step) + (let ((passphrase + (sasl-read-passphrase + (format "CRAM-MD5 passphrase for %s: " + (sasl-client-name client))))) + (unwind-protect + (concat (sasl-client-name client) " " + (encode-hex-string + (hmac-md5 (sasl-step-data step) passphrase))) + (fillarray passphrase 0)))) + +(put 'sasl-cram 'sasl-mechanism + (sasl-make-mechanism "CRAM-MD5" sasl-cram-md5-steps)) + +(provide 'sasl-cram) + +;;; arch-tag: 46cb281b-975a-4fe0-a39f-3018691b1b05 +;;; sasl-cram.el ends here diff --git a/lisp/net/sasl-digest.el b/lisp/net/sasl-digest.el new file mode 100644 index 00000000000..6c544518e7f --- /dev/null +++ b/lisp/net/sasl-digest.el @@ -0,0 +1,159 @@ +;;; sasl-digest.el --- DIGEST-MD5 module for the SASL client framework + +;; Copyright (C) 2000, 2007 Free Software Foundation, Inc. + +;; Author: Daiki Ueno +;; Kenichi OKADA +;; Keywords: SASL, DIGEST-MD5 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This program is implemented from draft-leach-digest-sasl-05.txt. +;; +;; It is caller's responsibility to base64-decode challenges and +;; base64-encode responses in IMAP4 AUTHENTICATE command. +;; +;; Passphrase should be longer than 16 bytes. (See RFC 2195) + +;;; Commentary: + +(require 'sasl) +(require 'hmac-md5) + +(defvar sasl-digest-md5-nonce-count 1) +(defvar sasl-digest-md5-unique-id-function + sasl-unique-id-function) + +(defvar sasl-digest-md5-syntax-table + (let ((table (make-syntax-table))) + (modify-syntax-entry ?= "." table) + (modify-syntax-entry ?, "." table) + table) + "A syntax table for parsing digest-challenge attributes.") + +(defconst sasl-digest-md5-steps + '(ignore ;no initial response + sasl-digest-md5-response + ignore)) ;"" + +(defun sasl-digest-md5-parse-string (string) + "Parse STRING and return a property list. +The value is a cons cell of the form \(realm nonce qop-options stale maxbuf +charset algorithm cipher-opts auth-param)." + (with-temp-buffer + (set-syntax-table sasl-digest-md5-syntax-table) + (save-excursion + (insert string) + (goto-char (point-min)) + (insert "(") + (while (progn (forward-sexp) (not (eobp))) + (delete-char 1) + (insert " ")) + (insert ")") + (read (point-min-marker))))) + +(defun sasl-digest-md5-digest-uri (serv-type host &optional serv-name) + (concat serv-type "/" host + (if (and serv-name + (not (string= host serv-name))) + (concat "/" serv-name)))) + +(defun sasl-digest-md5-cnonce () + (let ((sasl-unique-id-function sasl-digest-md5-unique-id-function)) + (sasl-unique-id))) + +(defun sasl-digest-md5-response-value (username + realm + nonce + cnonce + nonce-count + qop + digest-uri + authzid) + (let ((passphrase + (sasl-read-passphrase + (format "DIGEST-MD5 passphrase for %s: " + username)))) + (unwind-protect + (encode-hex-string + (md5-binary + (concat + (encode-hex-string + (md5-binary (concat (md5-binary + (concat username ":" realm ":" passphrase)) + ":" nonce ":" cnonce + (if authzid + (concat ":" authzid))))) + ":" nonce + ":" (format "%08x" nonce-count) ":" cnonce ":" qop ":" + (encode-hex-string + (md5-binary + (concat "AUTHENTICATE:" digest-uri + (if (member qop '("auth-int" "auth-conf")) + ":00000000000000000000000000000000"))))))) + (fillarray passphrase 0)))) + +(defun sasl-digest-md5-response (client step) + (let* ((plist + (sasl-digest-md5-parse-string (sasl-step-data step))) + (realm + (or (sasl-client-property client 'realm) + (plist-get plist 'realm))) ;need to check + (nonce-count + (or (sasl-client-property client 'nonce-count) + sasl-digest-md5-nonce-count)) + (qop + (or (sasl-client-property client 'qop) + "auth")) + (digest-uri + (sasl-digest-md5-digest-uri + (sasl-client-service client)(sasl-client-server client))) + (cnonce + (or (sasl-client-property client 'cnonce) + (sasl-digest-md5-cnonce)))) + (sasl-client-set-property client 'nonce-count (1+ nonce-count)) + (unless (string= qop "auth") + (sasl-error (format "Unsupported \"qop-value\": %s" qop))) + (concat + "username=\"" (sasl-client-name client) "\"," + "realm=\"" realm "\"," + "nonce=\"" (plist-get plist 'nonce) "\"," + "cnonce=\"" cnonce "\"," + (format "nc=%08x," nonce-count) + "digest-uri=\"" digest-uri "\"," + "qop=" qop "," + "response=" + (sasl-digest-md5-response-value + (sasl-client-name client) + realm + (plist-get plist 'nonce) + cnonce + nonce-count + qop + digest-uri + (plist-get plist 'authzid))))) + +(put 'sasl-digest 'sasl-mechanism + (sasl-make-mechanism "DIGEST-MD5" sasl-digest-md5-steps)) + +(provide 'sasl-digest) + +;;; arch-tag: 786e02ed-1bc4-4b3c-bf34-96c27e31084d +;;; sasl-digest.el ends here diff --git a/lisp/net/sasl-ntlm.el b/lisp/net/sasl-ntlm.el new file mode 100644 index 00000000000..cd8304db70a --- /dev/null +++ b/lisp/net/sasl-ntlm.el @@ -0,0 +1,68 @@ +;;; sasl-ntlm.el --- NTLM (NT Lan Manager) module for the SASL client framework + +;; Copyright (C) 2000, 2007 Free Software Foundation, Inc. + +;; Author: Taro Kawagishi +;; Keywords: SASL, NTLM +;; Version: 1.00 +;; Created: February 2001 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This is a SASL interface layer for NTLM authentication message +;; generation by ntlm.el + +;;; Code: + +(require 'sasl) +(require 'ntlm) + +(defconst sasl-ntlm-steps + '(ignore ;nothing to do before making + sasl-ntlm-request ;authentication request + sasl-ntlm-response) ;response to challenge + "A list of functions to be called in sequnece for the NTLM +authentication steps. Ther are called by 'sasl-next-step.") + +(defun sasl-ntlm-request (client step) + "SASL step function to generate a NTLM authentication request to the server. +Called from 'sasl-next-step. +CLIENT is a vector [mechanism user service server sasl-client-properties] +STEP is a vector [ ]" + (let ((user (sasl-client-name client))) + (ntlm-build-auth-request user))) + +(defun sasl-ntlm-response (client step) + "SASL step function to generate a NTLM response against the server +challenge stored in the 2nd element of STEP. Called from 'sasl-next-step." + (let* ((user (sasl-client-name client)) + (passphrase + (sasl-read-passphrase (format "NTLM passphrase for %s: " user))) + (challenge (sasl-step-data step))) + (ntlm-build-auth-response challenge user + (ntlm-get-password-hashes passphrase)))) + +(put 'sasl-ntlm 'sasl-mechanism + (sasl-make-mechanism "NTLM" sasl-ntlm-steps)) + +(provide 'sasl-ntlm) + +;;; arch-tag: 1d9164c1-1df0-418f-b7ab-360157fd05dc +;;; sasl-ntlm.el ends here diff --git a/lisp/net/sasl.el b/lisp/net/sasl.el new file mode 100644 index 00000000000..9118d288da4 --- /dev/null +++ b/lisp/net/sasl.el @@ -0,0 +1,273 @@ +;;; sasl.el --- SASL client framework + +;; Copyright (C) 2000, 2007 Free Software Foundation, Inc. + +;; Author: Daiki Ueno +;; Keywords: SASL + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This module provides common interface functions to share several +;; SASL mechanism drivers. The toplevel is designed to be mostly +;; compatible with [Java-SASL]. +;; +;; [SASL] J. Myers, "Simple Authentication and Security Layer (SASL)", +;; RFC 2222, October 1997. +;; +;; [Java-SASL] R. Weltman & R. Lee, "The Java SASL Application Program +;; Interface", draft-weltman-java-sasl-03.txt, March 2000. + +;;; Code: + +(defvar sasl-mechanisms + '("CRAM-MD5" "DIGEST-MD5" "PLAIN" "LOGIN" "ANONYMOUS" + "NTLM" "SCRAM-MD5")) + +(defvar sasl-mechanism-alist + '(("CRAM-MD5" sasl-cram) + ("DIGEST-MD5" sasl-digest) + ("PLAIN" sasl-plain) + ("LOGIN" sasl-login) + ("ANONYMOUS" sasl-anonymous) + ("NTLM" sasl-ntlm) + ("SCRAM-MD5" sasl-scram))) + +(defvar sasl-unique-id-function #'sasl-unique-id-function) + +(put 'sasl-error 'error-message "SASL error") +(put 'sasl-error 'error-conditions '(sasl-error error)) + +(defun sasl-error (datum) + (signal 'sasl-error (list datum))) + +;;; @ SASL client +;;; + +(defun sasl-make-client (mechanism name service server) + "Return a newly allocated SASL client. +NAME is name of the authorization. SERVICE is name of the service desired. +SERVER is the fully qualified host name of the server to authenticate to." + (vector mechanism name service server (make-symbol "sasl-client-properties"))) + +(defun sasl-client-mechanism (client) + "Return the authentication mechanism driver of CLIENT." + (aref client 0)) + +(defun sasl-client-name (client) + "Return the authorization name of CLIENT, a string." + (aref client 1)) + +(defun sasl-client-service (client) + "Return the service name of CLIENT, a string." + (aref client 2)) + +(defun sasl-client-server (client) + "Return the server name of CLIENT, a string." + (aref client 3)) + +(defun sasl-client-set-properties (client plist) + "Destructively set the properties of CLIENT. +The second argument PLIST is the new property list." + (setplist (aref client 4) plist)) + +(defun sasl-client-set-property (client property value) + "Add the given property/value to CLIENT." + (put (aref client 4) property value)) + +(defun sasl-client-property (client property) + "Return the value of the PROPERTY of CLIENT." + (get (aref client 4) property)) + +(defun sasl-client-properties (client) + "Return the properties of CLIENT." + (symbol-plist (aref client 4))) + +;;; @ SASL mechanism +;;; + +(defun sasl-make-mechanism (name steps) + "Make an authentication mechanism. +NAME is a IANA registered SASL mechanism name. +STEPS is list of continuation function." + (vector name + (mapcar + (lambda (step) + (let ((symbol (make-symbol (symbol-name step)))) + (fset symbol (symbol-function step)) + symbol)) + steps))) + +(defun sasl-mechanism-name (mechanism) + "Return name of MECHANISM, a string." + (aref mechanism 0)) + +(defun sasl-mechanism-steps (mechanism) + "Return the authentication steps of MECHANISM, a list of functions." + (aref mechanism 1)) + +(defun sasl-find-mechanism (mechanisms) + "Retrieve an apropriate mechanism object from MECHANISMS hints." + (let* ((sasl-mechanisms sasl-mechanisms) + (mechanism + (catch 'done + (while sasl-mechanisms + (if (member (car sasl-mechanisms) mechanisms) + (throw 'done (nth 1 (assoc (car sasl-mechanisms) + sasl-mechanism-alist)))) + (setq sasl-mechanisms (cdr sasl-mechanisms)))))) + (if mechanism + (require mechanism)) + (get mechanism 'sasl-mechanism))) + +;;; @ SASL authentication step +;;; + +(defun sasl-step-data (step) + "Return the data which STEP holds, a string." + (aref step 1)) + +(defun sasl-step-set-data (step data) + "Store DATA string to STEP." + (aset step 1 data)) + +(defun sasl-next-step (client step) + "Evaluate the challenge and prepare an appropriate next response. +The data type of the value and optional 2nd argument STEP is nil or +opaque authentication step which holds the reference to the next action +and the current challenge. At the first time STEP should be set to nil." + (let* ((steps + (sasl-mechanism-steps + (sasl-client-mechanism client))) + (function + (if (vectorp step) + (nth 1 (memq (aref step 0) steps)) + (car steps)))) + (if function + (vector function (funcall function client step))))) + +(defvar sasl-read-passphrase nil) +(defun sasl-read-passphrase (prompt) + (if (not sasl-read-passphrase) + (if (functionp 'read-passwd) + (setq sasl-read-passphrase 'read-passwd) + (if (load "passwd" t) + (setq sasl-read-passphrase 'read-passwd) + (autoload 'ange-ftp-read-passwd "ange-ftp") + (setq sasl-read-passphrase 'ange-ftp-read-passwd)))) + (funcall sasl-read-passphrase prompt)) + +(defun sasl-unique-id () + "Compute a data string which must be different each time. +It contain at least 64 bits of entropy." + (concat (funcall sasl-unique-id-function)(funcall sasl-unique-id-function))) + +(defvar sasl-unique-id-char nil) + +;; stolen (and renamed) from message.el +(defun sasl-unique-id-function () + ;; Don't use microseconds from (current-time), they may be unsupported. + ;; Instead we use this randomly inited counter. + (setq sasl-unique-id-char + (% (1+ (or sasl-unique-id-char (logand (random t) (1- (lsh 1 20))))) + ;; (current-time) returns 16-bit ints, + ;; and 2^16*25 just fits into 4 digits i base 36. + (* 25 25))) + (let ((tm (current-time))) + (concat + (sasl-unique-id-number-base36 + (+ (car tm) + (lsh (% sasl-unique-id-char 25) 16)) 4) + (sasl-unique-id-number-base36 + (+ (nth 1 tm) + (lsh (/ sasl-unique-id-char 25) 16)) 4)))) + +(defun sasl-unique-id-number-base36 (num len) + (if (if (< len 0) + (<= num 0) + (= len 0)) + "" + (concat (sasl-unique-id-number-base36 (/ num 36) (1- len)) + (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210" + (% num 36)))))) + +;;; PLAIN (RFC2595 Section 6) +(defconst sasl-plain-steps + '(sasl-plain-response)) + +(defun sasl-plain-response (client step) + (let ((passphrase + (sasl-read-passphrase + (format "PLAIN passphrase for %s: " (sasl-client-name client)))) + (authenticator-name + (sasl-client-property + client 'authenticator-name)) + (name (sasl-client-name client))) + (unwind-protect + (if (and authenticator-name + (not (string= authenticator-name name))) + (concat authenticator-name "\0" name "\0" passphrase) + (concat "\0" name "\0" passphrase)) + (fillarray passphrase 0)))) + +(put 'sasl-plain 'sasl-mechanism + (sasl-make-mechanism "PLAIN" sasl-plain-steps)) + +(provide 'sasl-plain) + +;;; LOGIN (No specification exists) +(defconst sasl-login-steps + '(ignore ;no initial response + sasl-login-response-1 + sasl-login-response-2)) + +(defun sasl-login-response-1 (client step) +;;; (unless (string-match "^Username:" (sasl-step-data step)) +;;; (sasl-error (format "Unexpected response: %s" (sasl-step-data step)))) + (sasl-client-name client)) + +(defun sasl-login-response-2 (client step) +;;; (unless (string-match "^Password:" (sasl-step-data step)) +;;; (sasl-error (format "Unexpected response: %s" (sasl-step-data step)))) + (sasl-read-passphrase + (format "LOGIN passphrase for %s: " (sasl-client-name client)))) + +(put 'sasl-login 'sasl-mechanism + (sasl-make-mechanism "LOGIN" sasl-login-steps)) + +(provide 'sasl-login) + +;;; ANONYMOUS (RFC2245) +(defconst sasl-anonymous-steps + '(ignore ;no initial response + sasl-anonymous-response)) + +(defun sasl-anonymous-response (client step) + (or (sasl-client-property client 'trace) + (sasl-client-name client))) + +(put 'sasl-anonymous 'sasl-mechanism + (sasl-make-mechanism "ANONYMOUS" sasl-anonymous-steps)) + +(provide 'sasl-anonymous) + +(provide 'sasl) + +;;; arch-tag: 8b3326fa-4978-4fda-93e2-cb2c6255f887 +;;; sasl.el ends here