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 (require 'poe)
  28
  29 (defvar sasl-mechanisms
  30   '("CRAM-MD5" "DIGEST-MD5" "PLAIN"))
  31
  32 (defvar sasl-mechanism-alist
  33   '(("CRAM-MD5" sasl-cram)
  34     ("DIGEST-MD5" sasl-digest)
  35     ("PLAIN" sasl-plain)))
  36
  37 (defvar sasl-unique-id-function #'sasl-unique-id-function)
  38
  39 (defun sasl-make-authenticator (mechanism continuations)
  40   (vector mechanism
  41           (mapcar
  42            (lambda (continuation)
  43              (let ((symbol (make-symbol (symbol-name continuation))))
  44                (fset symbol (symbol-function continuation))
  45                symbol))
  46            continuations)))
  47
  48 (defmacro sasl-authenticator-mechanism-internal (authenticator)
  49   `(aref ,authenticator 0))
  50
  51 (defmacro sasl-authenticator-continuations-internal (authenticator)
  52   `(aref ,authenticator 1))
  53
  54 (defmacro sasl-make-principal (name service server &optional realm)
  55   `(vector ,name ,realm ,service ,server))
  56
  57 (defmacro sasl-principal-name-internal (principal)
  58   `(aref ,principal 0))
  59
  60 (defmacro sasl-principal-realm-internal (principal)
  61   `(aref ,principal 1))
  62
  63 (defmacro sasl-principal-service-internal (principal)
  64   `(aref ,principal 2))
  65
  66 (defmacro sasl-principal-server-internal (principal)
  67   `(aref ,principal 3))
  68
  69 (defun sasl-find-authenticator (mechanisms)
  70   "Retrieve an apropriate authenticator object from MECHANISMS hints."
  71   (let* ((sasl-mechanisms sasl-mechanisms)
  72          (mechanism
  73           (catch 'done
  74             (while sasl-mechanisms
  75               (if (member (car sasl-mechanisms) mechanisms)
  76                   (throw 'done (nth 1 (assoc (car sasl-mechanisms)
  77                                              sasl-mechanism-alist))))
  78               (setq sasl-mechanisms (cdr sasl-mechanisms))))))
  79     (when mechanism
  80       (require mechanism)
  81       (get mechanism 'sasl-authenticator))))
  82
  83 (defun sasl-evaluate-challenge (authenticator principal &optional challenge)
  84   "Evaluate the challenge and prepare an appropriate next response.
  85 The data type of the value and the CHALLENGE is nil or a cons cell of the form
  86 \(CONTINUATION STRING).  At the first time CONTINUATION should be set to nil."
  87   (let* ((continuations
  88           (sasl-authenticator-continuations-internal authenticator))
  89          (function
  90           (if (car challenge)
  91               (nth 1 (memq (car challenge) continuations))
  92             (car continuations))))
  93     (if function
  94         (list function (funcall function principal challenge)))))
  95
  96 (defvar sasl-read-passphrase nil)
  97 (defun sasl-read-passphrase (prompt &optional key)
  98   (if (not sasl-read-passphrase)
  99       (if (functionp 'read-passwd)
 100           (setq sasl-read-passphrase 'read-passwd)
 101         (if (load "passwd" t)
 102             (setq sasl-read-passphrase 'read-passwd)
 103           (autoload 'ange-ftp-read-passwd "ange-ftp")
 104           (setq sasl-read-passphrase 'ange-ftp-read-passwd))))
 105   (funcall sasl-read-passphrase prompt))
 106
 107 (defun sasl-unique-id ()
 108   "Compute a data string which must be different each time.
 109 It contain at least 64 bits of entropy."
 110   (concat (funcall sasl-unique-id-function)(funcall sasl-unique-id-function)))
 111
 112 (defvar sasl-unique-id-char nil)
 113
 114 ;; stolen (and renamed) from message.el
 115 (defun sasl-unique-id-function ()
 116   ;; Don't use microseconds from (current-time), they may be unsupported.
 117   ;; Instead we use this randomly inited counter.
 118   (setq sasl-unique-id-char
 119         (% (1+ (or sasl-unique-id-char (logand (random t) (1- (lsh 1 20)))))
 120            ;; (current-time) returns 16-bit ints,
 121            ;; and 2^16*25 just fits into 4 digits i base 36.
 122            (* 25 25)))
 123   (let ((tm (current-time)))
 124     (concat
 125      (sasl-unique-id-number-base36
 126       (+ (car   tm)
 127          (lsh (% sasl-unique-id-char 25) 16)) 4)
 128      (sasl-unique-id-number-base36
 129       (+ (nth 1 tm)
 130          (lsh (/ sasl-unique-id-char 25) 16)) 4))))
 131
 132 (defun sasl-unique-id-number-base36 (num len)
 133   (if (if (< len 0)
 134           (<= num 0)
 135         (= len 0))
 136       ""
 137     (concat (sasl-unique-id-number-base36 (/ num 36) (1- len))
 138             (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210"
 139                                   (% num 36))))))
 140
 141 ;;; PLAIN SASL mechanism (RFC2595 Section 6)
 142 (defconst sasl-plain-continuations
 143   '(sasl-plain-response))
 144
 145 (defun sasl-plain-response (principal challenge)
 146   (let ((passphrase
 147          (sasl-read-passphrase
 148           (format "PLAIN passphrase for %s: "
 149                   (sasl-principal-name-internal principal)))))
 150     (unwind-protect
 151         (concat "\0" (sasl-principal-name-internal principal) "\0" passphrase)
 152       (fillarray passphrase 0))))
 153
 154 (put 'sasl-plain 'sasl-authenticator
 155      (sasl-make-authenticator "PLAIN" sasl-plain-continuations))
 156
 157 (provide 'sasl-plain)
 158
 159 (provide 'sasl)
 160
 161 ;;; sasl.el ends here