mail/sasl.el

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