cgit.sxemacs.org Git - gnus/blob - lisp/sasl-scram-rfc.el

   1 ;;; sasl-scram-rfc.el --- SCRAM-SHA-1 module for the SASL client framework  -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
   4
   5 ;; Author: Magnus Henoch <magnus.henoch@gmail.com>
   6 ;; Package: sasl
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; This program is implemented from RFC 5802.  It implements the
  26 ;; SCRAM-SHA-1 SASL mechanism.
  27 ;;
  28 ;; RFC 5802 foresees "hash agility", i.e. new mechanisms based on the
  29 ;; same protocol but using a different hash function.  Likewise, this
  30 ;; module attempts to separate generic and specific functions, which
  31 ;; should make it easy to implement any future SCRAM-* SASL mechanism.
  32 ;; It should be as simple as copying the SCRAM-SHA-1 section below and
  33 ;; replacing all SHA-1 references.
  34 ;;
  35 ;; This module does not yet implement the variants with channel
  36 ;; binding, i.e. SCRAM-*-PLUS.  That would require cooperation from
  37 ;; the TLS library.
  38
  39 ;;; Code:
  40
  41 (ignore-errors (require 'cl-lib))
  42
  43 (require 'sasl)
  44 (require 'hex-util)
  45 (require 'rfc2104)
  46
  47 ;;; Generic for SCRAM-*
  48
  49 (defun sasl-scram-client-first-message (client _step)
  50   (let ((c-nonce (sasl-unique-id)))
  51     (sasl-client-set-property client 'c-nonce c-nonce))
  52   (concat
  53    ;; n = client doesn't support channel binding
  54    "n,"
  55    ;; TODO: where would we get authorization id from?
  56    ","
  57    (sasl-scram--client-first-message-bare client)))
  58
  59 (defun sasl-scram--client-first-message-bare (client)
  60   (let ((c-nonce (sasl-client-property client 'c-nonce)))
  61     (concat
  62      ;; TODO: saslprep username or disallow non-ASCII characters
  63      "n=" (sasl-client-name client) ","
  64      "r=" c-nonce)))
  65
  66 (eval-and-compile
  67   (declare-function sasl-cl-coerce "sasl-scram-rfc")
  68   (declare-function sasl-cl-mapcar-many "sasl-scram-rfc")
  69   (if (fboundp 'cl-map)
  70       (defalias 'sasl-cl-map 'cl-map)
  71     (defun sasl-cl-mapcar-many (func seqs)
  72       (if (cdr (cdr seqs))
  73           (let* ((res nil)
  74                  (n (apply 'min (mapcar 'length seqs)))
  75                  (i 0)
  76                  (args (copy-sequence seqs))
  77                  p1 p2)
  78             (setq seqs (copy-sequence seqs))
  79             (while (< i n)
  80               (setq p1 seqs p2 args)
  81               (while p1
  82                 (setcar p2
  83                         (if (consp (car p1))
  84                             (prog1 (car (car p1))
  85                               (setcar p1 (cdr (car p1))))
  86                           (aref (car p1) i)))
  87                 (setq p1 (cdr p1) p2 (cdr p2)))
  88               (push (apply func args) res)
  89               (setq i (1+ i)))
  90             (nreverse res))
  91         (let ((res nil)
  92               (x (car seqs))
  93               (y (nth 1 seqs)))
  94           (let ((n (min (length x) (length y)))
  95                 (i -1))
  96             (while (< (setq i (1+ i)) n)
  97               (push (funcall func
  98                              (if (consp x) (pop x) (aref x i))
  99                              (if (consp y) (pop y) (aref y i)))
 100                     res)))
 101           (nreverse res))))
 102
 103     (defun sasl-cl-coerce (x type)
 104       "Coerce OBJECT to type TYPE.
 105 TYPE is a Common Lisp type specifier.
 106 \n(fn OBJECT TYPE)"
 107       (cond ((eq type 'list) (if (listp x) x (append x nil)))
 108             ((eq type 'vector) (if (vectorp x) x (vconcat x)))
 109             ((eq type 'string) (if (stringp x) x (concat x)))
 110             ((eq type 'array) (if (arrayp x) x (vconcat x)))
 111             ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0))
 112             ((and (eq type 'character) (symbolp x))
 113              (sasl-cl-coerce (symbol-name x) type))
 114             ((eq type 'float) (float x))
 115             ;;((cl-typep x type) x)
 116             (t (error "Can't coerce %s to type %s" x type))))
 117
 118     (defun sasl-cl-map (type func seq &rest rest)
 119       "Map a FUNCTION across one or more SEQUENCEs, returning a sequence.
 120 TYPE is the sequence type to return.
 121 \n(fn TYPE FUNCTION SEQUENCE...)"
 122       (let (res y)
 123         (if rest
 124             (if (or (cdr rest) (nlistp seq) (nlistp (car rest)))
 125                 (setq res (sasl-cl-mapcar-many func (cons seq rest)))
 126               (setq y (car rest))
 127               (while (and seq y)
 128                 (push (funcall func (pop seq) (pop y)) res))
 129               (setq res (nreverse res)))
 130           (setq res (mapcar func seq)))
 131         (and type (sasl-cl-coerce res type)))))
 132
 133   (if (fboundp 'string-prefix-p)
 134       (defalias 'sasl-string-prefix-p 'string-prefix-p)
 135     (defun sasl-string-prefix-p (prefix string &optional ignore-case)
 136       "Return non-nil if PREFIX is a prefix of STRING.
 137 If IGNORE-CASE is non-nil, the comparison is done without paying attention
 138 to case differences."
 139       (let ((prefix-length (length prefix)))
 140         (cond ((> prefix-length (length string)) nil)
 141               (ignore-case
 142                (string-equal (downcase prefix)
 143                              (downcase (substring string 0 prefix-length))))
 144               (t
 145                (string-equal prefix (substring string 0 prefix-length))))))))
 146
 147 (defun sasl-scram--client-final-message (hash-fun block-length hash-length client step)
 148   (unless (string-match
 149            "^r=\\([^,]+\\),s=\\([^,]+\\),i=\\([0-9]+\\)\\(?:$\\|,\\)"
 150            (sasl-step-data step))
 151     (sasl-error "Unexpected server response"))
 152   (let* ((hmac-fun (lambda (text key)
 153                      (decode-hex-string
 154                       (rfc2104-hash hash-fun block-length hash-length key text))))
 155          (step-data (sasl-step-data step))
 156          (nonce (match-string 1 step-data))
 157          (salt-base64 (match-string 2 step-data))
 158          (iteration-count (string-to-number (match-string 3 step-data)))
 159
 160          (c-nonce (sasl-client-property client 'c-nonce))
 161          ;; no channel binding, no authorization id
 162          (cbind-input "n,,"))
 163     (unless (sasl-string-prefix-p c-nonce nonce)
 164       (sasl-error "Invalid nonce from server"))
 165     (let* ((client-final-message-without-proof
 166             (concat "c=" (base64-encode-string cbind-input) ","
 167                     "r=" nonce))
 168            (password
 169             ;; TODO: either apply saslprep or disallow non-ASCII characters
 170             (sasl-read-passphrase
 171              (format "%s passphrase for %s: "
 172                      (sasl-mechanism-name (sasl-client-mechanism client))
 173                      (sasl-client-name client))))
 174            (salt (base64-decode-string salt-base64))
 175            (salted-password
 176             ;; Hi(str, salt, i):
 177             (let ((digest (concat salt (string 0 0 0 1)))
 178                   (xored nil))
 179               (dotimes (_i iteration-count xored)
 180                 (setq digest (funcall hmac-fun digest password))
 181                 (setq xored (if (null xored)
 182                                 digest
 183                               (sasl-cl-map 'string 'logxor xored digest))))))
 184            (client-key
 185             (funcall hmac-fun "Client Key" salted-password))
 186            (stored-key (decode-hex-string (funcall hash-fun client-key)))
 187            (auth-message
 188             (concat
 189              (sasl-scram--client-first-message-bare client) ","
 190              step-data ","
 191              client-final-message-without-proof))
 192            (client-signature (funcall hmac-fun (encode-coding-string auth-message 'utf-8) stored-key))
 193            (client-proof (sasl-cl-map 'string 'logxor client-key client-signature))
 194            (client-final-message
 195             (concat client-final-message-without-proof ","
 196                     "p=" (base64-encode-string client-proof))))
 197       (sasl-client-set-property client 'auth-message auth-message)
 198       (sasl-client-set-property client 'salted-password salted-password)
 199       client-final-message)))
 200
 201 (defun sasl-scram--authenticate-server (hash-fun block-length hash-length client step)
 202   (cond
 203    ((string-match "^e=\\([^,]+\\)" (sasl-step-data step))
 204     (sasl-error (format "Server error: %s" (match-string 1 (sasl-step-data step)))))
 205    ((string-match "^v=\\([^,]+\\)" (sasl-step-data step))
 206     (let* ((hmac-fun (lambda (text key)
 207                        (decode-hex-string
 208                         (rfc2104-hash hash-fun block-length hash-length key text))))
 209            (verifier (base64-decode-string (match-string 1 (sasl-step-data step))))
 210            (auth-message (sasl-client-property client 'auth-message))
 211            (salted-password (sasl-client-property client 'salted-password))
 212            (server-key (funcall hmac-fun "Server Key" salted-password))
 213            (expected-server-signature
 214             (funcall hmac-fun (encode-coding-string auth-message 'utf-8) server-key)))
 215       (unless (string= expected-server-signature verifier)
 216         (sasl-error "Server not authenticated"))))
 217    (t
 218     (sasl-error "Invalid response from server"))))
 219
 220 ;;; SCRAM-SHA-1
 221
 222 (defconst sasl-scram-sha-1-steps
 223   '(sasl-scram-client-first-message
 224     sasl-scram-sha-1-client-final-message
 225     sasl-scram-sha-1-authenticate-server))
 226
 227 (defun sasl-scram-sha-1-client-final-message (client step)
 228   (sasl-scram--client-final-message
 229    ;; HMAC-SHA1 uses block length 64 and hash length 20; see RFC 2104.
 230    'sha1 64 20 client step))
 231
 232 (defun sasl-scram-sha-1-authenticate-server (client step)
 233   (sasl-scram--authenticate-server
 234    'sha1 64 20 client step))
 235
 236 ;; This needs to be at the end, because of how `sasl-make-mechanism'
 237 ;; handles step function names.
 238 (put 'sasl-scram-sha-1 'sasl-mechanism
 239      (sasl-make-mechanism "SCRAM-SHA-1" sasl-scram-sha-1-steps))
 240
 241 (put 'sasl-scram-rfc 'sasl-mechanism (get 'sasl-scram-sha-1 'sasl-mechanism))
 242
 243 (provide 'sasl-scram-sha-1)
 244
 245 (provide 'sasl-scram-rfc)
 246 ;;; sasl-scram-rfc.el ends here