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
  28 ;;; Code:
  29
  30 (require 'poe)
  31
  32 (defvar sasl-mechanisms
  33   '("CRAM-MD5" "DIGEST-MD5" "PLAIN" "LOGIN" "ANONYMOUS"))
  34
  35 (defvar sasl-mechanism-alist
  36   '(("CRAM-MD5" sasl-cram)
  37     ("DIGEST-MD5" sasl-digest)
  38     ("PLAIN" sasl-plain)
  39     ("LOGIN" sasl-login)
  40     ("ANONYMOUS" sasl-anonymous)))
  41
  42 (defvar sasl-unique-id-function #'sasl-unique-id-function)
  43
  44 (put 'sasl-error 'error-message "SASL error")
  45 (put 'sasl-error 'error-conditions '(sasl-error error))
  46
  47 (defun sasl-error (datum)
  48   (signal 'sasl-error (list datum)))
  49
  50 ;;; @ SASL instantiator
  51 ;;;
  52
  53 (defmacro sasl-make-instantiator (name service server)
  54   "Return a newly allocated SASL instantiator.
  55 NAME is name of the authorization.  SERVICE is name of the service desired.
  56 SERVER is the fully qualified host name of the server to authenticate to."
  57   (let ((props (make-symbol "sasl-instantiator-properties")))
  58     `(vector ,name ,service ,server ',props)))
  59
  60 (defmacro sasl-instantiator-name (instantiator)
  61   "Return the authorization name of INSTANTIATOR, a string."
  62   `(aref ,instantiator 0))
  63
  64 (defmacro sasl-instantiator-service (instantiator)
  65   "Return the service name of INSTANTIATOR, a string."
  66   `(aref ,instantiator 1))
  67
  68 (defmacro sasl-instantiator-server (instantiator)
  69   "Return the server name of INSTANTIATOR, a string."
  70   `(aref ,instantiator 2))
  71
  72 (defmacro sasl-instantiator-set-properties (instantiator plist)
  73   "Destructively set the properties of INSTANTIATOR.
  74 The second argument PLIST is the new property list."
  75   `(setplist (aref ,instantiator 3) ,plist))
  76
  77 (defmacro sasl-instantiator-set-property (instantiator property value)
  78   "Add the given property/value to INSTANTIATOR."
  79   `(put (aref ,instantiator 3) ,property ,value))
  80
  81 (defmacro sasl-instantiator-property (instantiator property)
  82   "Return the value of the PROPERTY of INSTANTIATOR."
  83   `(get (aref ,instantiator 3) ,property))
  84
  85 (defmacro sasl-instantiator-properties (instantiator)
  86   "Return the properties of INSTANTIATOR."
  87   `(symbol-plist (aref ,instantiator 3)))
  88
  89 ;;; @ SASL authenticator
  90 ;;;
  91
  92 (defun sasl-make-authenticator (mechanism continuations)
  93   "Make an authenticator.
  94 MECHANISM is a IANA registered SASL mechanism name.
  95 CONTINUATIONS is list of continuation function."
  96   (vector mechanism
  97           (mapcar
  98            (lambda (continuation)
  99              (let ((symbol (make-symbol (symbol-name continuation))))
 100                (fset symbol (symbol-function continuation))
 101                symbol))
 102            continuations)))
 103
 104 (defmacro sasl-authenticator-mechanism (authenticator)
 105   "Return name of the mechanism AUTHENTICATOR supports, a string."
 106   `(aref ,authenticator 0))
 107
 108 (defmacro sasl-authenticator-continuations (authenticator)
 109   "Return continuation steps of AUTHENTICATOR, a list of functions."
 110   `(aref ,authenticator 1))
 111
 112 (defun sasl-find-authenticator (mechanisms)
 113   "Retrieve an apropriate authenticator object from MECHANISMS hints."
 114   (let* ((sasl-mechanisms sasl-mechanisms)
 115          (mechanism
 116           (catch 'done
 117             (while sasl-mechanisms
 118               (if (member (car sasl-mechanisms) mechanisms)
 119                   (throw 'done (nth 1 (assoc (car sasl-mechanisms)
 120                                              sasl-mechanism-alist))))
 121               (setq sasl-mechanisms (cdr sasl-mechanisms))))))
 122     (when mechanism
 123       (require mechanism)
 124       (get mechanism 'sasl-authenticator))))
 125
 126 (defun sasl-evaluate-challenge (authenticator instantiator &optional challenge)
 127   "Evaluate the challenge and prepare an appropriate next response.
 128 The data type of the value and optional 3rd argument CHALLENGE is nil or
 129 a cons cell of the form \(CONTINUATION STRING).
 130 At the first time CONTINUATION should be set to nil.
 131
 132 Argument AUTHENTICATOR is the current evaluator.
 133 Argument INSTANTIATOR is the instantiator instantiator."
 134   (let* ((continuations
 135           (sasl-authenticator-continuations authenticator))
 136          (function
 137           (if (car challenge)
 138               (nth 1 (memq (car challenge) continuations))
 139             (car continuations))))
 140     (if function
 141         (list function (funcall function instantiator challenge)))))
 142
 143 (defvar sasl-read-passphrase nil)
 144 (defun sasl-read-passphrase (prompt &optional key)
 145   (if (not sasl-read-passphrase)
 146       (if (functionp 'read-passwd)
 147           (setq sasl-read-passphrase 'read-passwd)
 148         (if (load "passwd" t)
 149             (setq sasl-read-passphrase 'read-passwd)
 150           (autoload 'ange-ftp-read-passwd "ange-ftp")
 151           (setq sasl-read-passphrase 'ange-ftp-read-passwd))))
 152   (funcall sasl-read-passphrase prompt))
 153
 154 (defun sasl-unique-id ()
 155   "Compute a data string which must be different each time.
 156 It contain at least 64 bits of entropy."
 157   (concat (funcall sasl-unique-id-function)(funcall sasl-unique-id-function)))
 158
 159 (defvar sasl-unique-id-char nil)
 160
 161 ;; stolen (and renamed) from message.el
 162 (defun sasl-unique-id-function ()
 163   ;; Don't use microseconds from (current-time), they may be unsupported.
 164   ;; Instead we use this randomly inited counter.
 165   (setq sasl-unique-id-char
 166         (% (1+ (or sasl-unique-id-char (logand (random t) (1- (lsh 1 20)))))
 167            ;; (current-time) returns 16-bit ints,
 168            ;; and 2^16*25 just fits into 4 digits i base 36.
 169            (* 25 25)))
 170   (let ((tm (current-time)))
 171     (concat
 172      (sasl-unique-id-number-base36
 173       (+ (car   tm)
 174          (lsh (% sasl-unique-id-char 25) 16)) 4)
 175      (sasl-unique-id-number-base36
 176       (+ (nth 1 tm)
 177          (lsh (/ sasl-unique-id-char 25) 16)) 4))))
 178
 179 (defun sasl-unique-id-number-base36 (num len)
 180   (if (if (< len 0)
 181           (<= num 0)
 182         (= len 0))
 183       ""
 184     (concat (sasl-unique-id-number-base36 (/ num 36) (1- len))
 185             (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210"
 186                                   (% num 36))))))
 187
 188 ;;; PLAIN (RFC2595 Section 6)
 189 (defconst sasl-plain-continuations
 190   '(sasl-plain-response))
 191
 192 (defun sasl-plain-response (instantiator challenge)
 193   (let ((passphrase
 194          (sasl-read-passphrase
 195           (format "PLAIN passphrase for %s: "
 196                   (sasl-instantiator-name instantiator))))
 197         (authentication-name
 198          (sasl-instantiator-property
 199           instantiator 'authentication-name))
 200         (name (sasl-instantiator-name instantiator)))
 201     (unwind-protect
 202         (if (and authentication-name
 203                  (not (string= authentication-name name)))
 204             (concat authentication-name "\0" name "\0" passphrase)
 205           (concat "\0" name "\0" passphrase))
 206       (fillarray passphrase 0))))
 207
 208 (put 'sasl-plain 'sasl-authenticator
 209      (sasl-make-authenticator "PLAIN" sasl-plain-continuations))
 210
 211 (provide 'sasl-plain)
 212
 213 ;;; LOGIN (No specification exists)
 214 (defconst sasl-login-continuations
 215   '(ignore                              ;no initial response
 216     sasl-login-response-1
 217     sasl-login-response-2))
 218
 219 (defun sasl-login-response-1 (instantiator challenge)
 220   (unless (string= (nth 1 challenge) "Username:")
 221     (sasl-error (format "Unexpected response: %s" (nth 1 challenge))))
 222   (sasl-instantiator-name instantiator))
 223
 224 (defun sasl-login-response-2 (instantiator challenge)
 225   (unless (string= (nth 1 challenge) "Password:")
 226     (sasl-error (format "Unexpected response: %s" (nth 1 challenge))))
 227   (sasl-read-passphrase
 228    (format "LOGIN passphrase for %s: " (sasl-instantiator-name instantiator))))
 229
 230 (put 'sasl-login 'sasl-authenticator
 231      (sasl-make-authenticator "LOGIN" sasl-login-continuations))
 232
 233 (provide 'sasl-login)
 234
 235 ;;; ANONYMOUS (RFC2245)
 236 (defconst sasl-anonymous-continuations
 237   '(identity                            ;no initial response
 238     sasl-anonymous-response))
 239
 240 (defun sasl-anonymous-response (instantiator challenge)
 241   (or (sasl-instantiator-property
 242        instantiator 'trace)
 243       (sasl-instantiator-name instantiator)))
 244
 245 (put 'sasl-anonymous 'sasl-authenticator
 246      (sasl-make-authenticator "ANONYMOUS" sasl-anonymous-continuations))
 247
 248 (provide 'sasl-anonymous)
 249
 250 (provide 'sasl)
 251
 252 ;;; sasl.el ends here