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