code.delx.au - gnu-emacs/blob - lisp/gnus/rfc2104.el

   1 ;;; rfc2104.el --- RFC2104 Hashed Message Authentication Codes
   2
   3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
   5
   6 ;; Author: Simon Josefsson <jas@pdc.kth.se>
   7 ;; Keywords: mail
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; This is a high performance implementation of RFC2104.
  27 ;;
  28 ;; Example:
  29 ;;
  30 ;; (require 'md5)
  31 ;; (rfc2104-hash 'md5 64 16 "Jefe" "what do ya want for nothing?")
  32 ;; "750c783e6ab0b503eaa86e310a5db738"
  33 ;;
  34 ;; (require 'sha1)
  35 ;; (rfc2104-hash 'sha1 64 20 "Jefe" "what do ya want for nothing?")
  36 ;; "effcdf6ae5eb2fa2d27416d5f184df9c259a7c79"
  37 ;;
  38 ;; 64 is block length of hash function (64 for MD5 and SHA), 16 is
  39 ;; resulting hash length (16 for MD5, 20 for SHA).
  40 ;;
  41 ;; Tested with Emacs 20.2 and XEmacs 20.3.
  42 ;;
  43 ;; Test case reference: RFC 2202.
  44
  45 ;;; History:
  46
  47 ;; 1998-08-16  initial release posted to gnu.emacs.sources
  48 ;; 1998-08-17  use append instead of char-list-to-string
  49 ;; 1998-08-26  don't require hexl
  50 ;; 1998-09-25  renamed from hmac.el to rfc2104.el, also renamed functions
  51 ;; 1999-10-23  included in pgnus
  52 ;; 2000-08-15  `rfc2104-hexstring-to-bitstring'
  53 ;; 2000-05-12  added sha-1 example, added test case reference
  54 ;; 2003-11-13  change rfc2104-hexstring-to-bitstring to ...-byte-list
  55 ;; 2008-04-25  rewrite rfc2104-hash for speed
  56
  57 ;;; Code:
  58
  59 (eval-when-compile (require 'cl))
  60
  61 ;; Magic character for inner HMAC round. 0x36 == 54 == '6'
  62 (defconst rfc2104-ipad ?\x36)
  63
  64 ;; Magic character for outer HMAC round. 0x5C == 92 == '\'
  65 (defconst rfc2104-opad ?\x5C)
  66
  67 (defconst rfc2104-nybbles
  68   (let ((v (make-vector
  69             ;; Find upper bound to save some space.
  70             (1+ (max ?0 ?9 ?a ?f ?A ?F))
  71             ;; Use non-numeric default to catch bogus hex strings.
  72             nil))
  73         (ls '((?0 . 0)   (?a . 10)   (?A . 10)
  74               (?1 . 1)   (?b . 11)   (?B . 11)
  75               (?2 . 2)   (?c . 12)   (?C . 12)
  76               (?3 . 3)   (?d . 13)   (?D . 13)
  77               (?4 . 4)   (?e . 14)   (?E . 14)
  78               (?5 . 5)   (?f . 15)   (?F . 15)
  79               (?6 . 6)
  80               (?7 . 7)
  81               (?8 . 8)
  82               (?9 . 9))))
  83     (while ls
  84       (aset v (caar ls) (cdar ls))
  85       (setq ls (cdr ls)))
  86     v))
  87
  88 (eval-when-compile
  89   (defmacro rfc2104-string-make-unibyte (string)
  90     "Return the unibyte equivalent of STRING.
  91 In XEmacs return just STRING."
  92     (if (featurep 'xemacs)
  93         string
  94       `(string-make-unibyte ,string))))
  95
  96 (defun rfc2104-hash (hash block-length hash-length key text)
  97   (let* (;; if key is longer than B, reset it to HASH(key)
  98          (key (if (> (length key) block-length)
  99                   (funcall hash key) key))
 100          (len (length key))
 101          (ipad (make-string    block-length              rfc2104-ipad))
 102          (opad (make-string (+ block-length hash-length) rfc2104-opad))
 103          c partial)
 104     ;; Prefix *pad with key, appropriately XORed.
 105     (do ((i 0 (1+ i)))
 106         ((= len i))
 107       (setq c (aref key i))
 108       (aset ipad i (logxor rfc2104-ipad c))
 109       (aset opad i (logxor rfc2104-opad c)))
 110     ;; Perform inner hash.
 111     (setq partial (rfc2104-string-make-unibyte
 112                    (funcall hash (concat ipad text))))
 113     ;; Pack latter part of opad.
 114     (do ((r 0 (+ 2 r))
 115          (w block-length (1+ w)))
 116         ((= (* 2 hash-length) r))
 117       (aset opad w
 118             (+ (* 16 (aref rfc2104-nybbles (aref partial     r)))
 119                (      aref rfc2104-nybbles (aref partial (1+ r))))))
 120     ;; Perform outer hash.
 121     (rfc2104-string-make-unibyte (funcall hash opad))))
 122
 123 (provide 'rfc2104)
 124
 125 ;; arch-tag: cf671d5c-a45f-4a09-815e-704e59e43950
 126 ;;; rfc2104.el ends here