sasl.el

   1 ;;; sasl.el --- SASL client framework
   2
   3 ;; Copyright (C) 2000 Daiki Ueno
   4
   5 ;; Author: Daiki Ueno <ueno@unixuser.org>
   6 ;; Keywords: SASL
   7
   8 ;; This file is part of FLIM (Faithful Library about Internet Message).
   9
  10 ;; This program is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or (at
  13 ;; your option) any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with this program; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; This module provides common interface functions to share several
  28 ;; SASL mechanism drivers.  The toplevel is designed to be mostly
  29 ;; compatible with [Java-SASL].
  30 ;;
  31 ;; [SASL] J. Myers, "Simple Authentication and Security Layer (SASL)",
  32 ;;      RFC 2222, October 1997.
  33 ;;
  34 ;; [Java-SASL] R. Weltman & R. Lee, "The Java SASL Application Program
  35 ;;      Interface", draft-weltman-java-sasl-03.txt, March 2000.
  36
  37 ;;; Code:
  38
  39 (require 'poe)
  40
  41 (defvar sasl-mechanisms
  42   '("CRAM-MD5" "DIGEST-MD5" "PLAIN" "LOGIN" "ANONYMOUS"))
  43
  44 (defvar sasl-mechanism-alist
  45   '(("CRAM-MD5" sasl-cram)
  46     ("DIGEST-MD5" sasl-digest)
  47     ("PLAIN" sasl-plain)
  48     ("LOGIN" sasl-login)
  49     ("ANONYMOUS" sasl-anonymous)))
  50
  51 (defvar sasl-unique-id-function #'sasl-unique-id-function)
  52
  53 (put 'sasl-error 'error-message "SASL error")
  54 (put 'sasl-error 'error-conditions '(sasl-error error))
  55
  56 (defun sasl-error (datum)
  57   (signal 'sasl-error (list datum)))
  58
  59 ;;; @ SASL instantiator
  60 ;;;
  61
  62 (defmacro sasl-make-instantiator (name service server)
  63   "Return a newly allocated SASL instantiator.
  64 NAME is name of the authorization.  SERVICE is name of the service desired.
  65 SERVER is the fully qualified host name of the server to authenticate to."
  66   (let ((props (make-symbol "sasl-instantiator-properties")))
  67     `(vector ,name ,service ,server ',props)))
  68
  69 (defmacro sasl-instantiator-name (instantiator)
  70   "Return the authorization name of INSTANTIATOR, a string."
  71   `(aref ,instantiator 0))
  72
  73 (defmacro sasl-instantiator-service (instantiator)
  74   "Return the service name of INSTANTIATOR, a string."
  75   `(aref ,instantiator 1))
  76
  77 (defmacro sasl-instantiator-server (instantiator)
  78   "Return the server name of INSTANTIATOR, a string."
  79   `(aref ,instantiator 2))
  80
  81 (defmacro sasl-instantiator-set-properties (instantiator plist)
  82   "Destructively set the properties of INSTANTIATOR.
  83 The second argument PLIST is the new property list."
  84   `(setplist (aref ,instantiator 3) ,plist))
  85
  86 (defmacro sasl-instantiator-set-property (instantiator property value)
  87   "Add the given property/value to INSTANTIATOR."
  88   `(put (aref ,instantiator 3) ,property ,value))
  89
  90 (defmacro sasl-instantiator-property (instantiator property)
  91   "Return the value of the PROPERTY of INSTANTIATOR."
  92   `(get (aref ,instantiator 3) ,property))
  93
  94 (defmacro sasl-instantiator-properties (instantiator)
  95   "Return the properties of INSTANTIATOR."
  96   `(symbol-plist (aref ,instantiator 3)))
  97
  98 ;;; @ SASL authenticator
  99 ;;;
 100
 101 (defun sasl-make-authenticator (mechanism continuations)
 102   "Make an authenticator.
 103 MECHANISM is a IANA registered SASL mechanism name.
 104 CONTINUATIONS is list of continuation function."
 105   (vector mechanism
 106           (mapcar
 107            (lambda (continuation)
 108              (let ((symbol (make-symbol (symbol-name continuation))))
 109                (fset symbol (symbol-function continuation))
 110                symbol))
 111            continuations)))
 112
 113 (defmacro sasl-authenticator-mechanism (authenticator)
 114   "Return name of the mechanism AUTHENTICATOR supports, a string."
 115   `(aref ,authenticator 0))
 116
 117 (defmacro sasl-authenticator-continuations (authenticator)
 118   "Return continuation steps of AUTHENTICATOR, a list of functions."
 119   `(aref ,authenticator 1))
 120
 121 (defun sasl-find-authenticator (mechanisms)
 122   "Retrieve an apropriate authenticator object from MECHANISMS hints."
 123   (let* ((sasl-mechanisms sasl-mechanisms)
 124          (mechanism
 125           (catch 'done
 126             (while sasl-mechanisms
 127               (if (member (car sasl-mechanisms) mechanisms)
 128                   (throw 'done (nth 1 (assoc (car sasl-mechanisms)
 129                                              sasl-mechanism-alist))))
 130               (setq sasl-mechanisms (cdr sasl-mechanisms))))))
 131     (when mechanism
 132       (require mechanism)
 133       (get mechanism 'sasl-authenticator))))
 134
 135 (defun sasl-evaluate-challenge (authenticator instantiator &optional challenge)
 136   "Evaluate the challenge and prepare an appropriate next response.
 137 The data type of the value and optional 3rd argument CHALLENGE is nil or
 138 a cons cell of the form \(CONTINUATION STRING).
 139 At the first time CONTINUATION should be set to nil.
 140
 141 Argument AUTHENTICATOR is the current evaluator.
 142 Argument INSTANTIATOR is the instantiator instantiator."
 143   (let* ((continuations
 144           (sasl-authenticator-continuations authenticator))
 145          (function
 146           (if (car challenge)
 147               (nth 1 (memq (car challenge) continuations))
 148             (car continuations))))
 149     (if function
 150         (list function (funcall function instantiator challenge)))))
 151
 152 (defvar sasl-read-passphrase nil)
 153 (defun sasl-read-passphrase (prompt)
 154   (if (not sasl-read-passphrase)
 155       (if (functionp 'read-passwd)
 156           (setq sasl-read-passphrase 'read-passwd)
 157         (if (load "passwd" t)
 158             (setq sasl-read-passphrase 'read-passwd)
 159           (autoload 'ange-ftp-read-passwd "ange-ftp")
 160           (setq sasl-read-passphrase 'ange-ftp-read-passwd))))
 161   (funcall sasl-read-passphrase prompt))
 162
 163 (defun sasl-unique-id ()
 164   "Compute a data string which must be different each time.
 165 It contain at least 64 bits of entropy."
 166   (concat (funcall sasl-unique-id-function)(funcall sasl-unique-id-function)))
 167
 168 (defvar sasl-unique-id-char nil)
 169
 170 ;; stolen (and renamed) from message.el
 171 (defun sasl-unique-id-function ()
 172   ;; Don't use microseconds from (current-time), they may be unsupported.
 173   ;; Instead we use this randomly inited counter.
 174   (setq sasl-unique-id-char
 175         (% (1+ (or sasl-unique-id-char (logand (random t) (1- (lsh 1 20)))))
 176            ;; (current-time) returns 16-bit ints,
 177            ;; and 2^16*25 just fits into 4 digits i base 36.
 178            (* 25 25)))
 179   (let ((tm (current-time)))
 180     (concat
 181      (sasl-unique-id-number-base36
 182       (+ (car   tm)
 183          (lsh (% sasl-unique-id-char 25) 16)) 4)
 184      (sasl-unique-id-number-base36
 185       (+ (nth 1 tm)
 186          (lsh (/ sasl-unique-id-char 25) 16)) 4))))
 187
 188 (defun sasl-unique-id-number-base36 (num len)
 189   (if (if (< len 0)
 190           (<= num 0)
 191         (= len 0))
 192       ""
 193     (concat (sasl-unique-id-number-base36 (/ num 36) (1- len))
 194             (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210"
 195                                   (% num 36))))))
 196
 197 ;;; PLAIN (RFC2595 Section 6)
 198 (defconst sasl-plain-continuations
 199   '(sasl-plain-response))
 200
 201 (defun sasl-plain-response (instantiator challenge)
 202   (let ((passphrase
 203          (sasl-read-passphrase
 204           (format "PLAIN passphrase for %s: "
 205                   (sasl-instantiator-name instantiator))))
 206         (authentication-name
 207          (sasl-instantiator-property
 208           instantiator 'authentication-name))
 209         (name (sasl-instantiator-name instantiator)))
 210     (unwind-protect
 211         (if (and authentication-name
 212                  (not (string= authentication-name name)))
 213             (concat authentication-name "\0" name "\0" passphrase)
 214           (concat "\0" name "\0" passphrase))
 215       (fillarray passphrase 0))))
 216
 217 (put 'sasl-plain 'sasl-authenticator
 218      (sasl-make-authenticator "PLAIN" sasl-plain-continuations))
 219
 220 (provide 'sasl-plain)
 221
 222 ;;; LOGIN (No specification exists)
 223 (defconst sasl-login-continuations
 224   '(ignore                              ;no initial response
 225     sasl-login-response-1
 226     sasl-login-response-2))
 227
 228 (defun sasl-login-response-1 (instantiator challenge)
 229   (unless (string= (nth 1 challenge) "Username:")
 230     (sasl-error (format "Unexpected response: %s" (nth 1 challenge))))
 231   (sasl-instantiator-name instantiator))
 232
 233 (defun sasl-login-response-2 (instantiator challenge)
 234   (unless (string= (nth 1 challenge) "Password:")
 235     (sasl-error (format "Unexpected response: %s" (nth 1 challenge))))
 236   (sasl-read-passphrase
 237    (format "LOGIN passphrase for %s: " (sasl-instantiator-name instantiator))))
 238
 239 (put 'sasl-login 'sasl-authenticator
 240      (sasl-make-authenticator "LOGIN" sasl-login-continuations))
 241
 242 (provide 'sasl-login)
 243
 244 ;;; ANONYMOUS (RFC2245)
 245 (defconst sasl-anonymous-continuations
 246   '(identity                            ;no initial response
 247     sasl-anonymous-response))
 248
 249 (defun sasl-anonymous-response (instantiator challenge)
 250   (or (sasl-instantiator-property
 251        instantiator 'trace)
 252       (sasl-instantiator-name instantiator)))
 253
 254 (put 'sasl-anonymous 'sasl-authenticator
 255      (sasl-make-authenticator "ANONYMOUS" sasl-anonymous-continuations))
 256
 257 (provide 'sasl-anonymous)
 258
 259 (provide 'sasl)
 260
 261 ;;; sasl.el ends here