cgit.sxemacs.org Git - packages/blob - xemacs-packages/vm/lisp/vm-crypto.el

   1 ;;; vm-crypto.el --- Encryption and related functions for VM
   2 ;;
   3 ;; Copyright (C) 2001 Kyle E. Jones
   4 ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk
   5 ;;
   6 ;; This program is free software; you can redistribute it and/or modify
   7 ;; it under the terms of the GNU General Public License as published by
   8 ;; the Free Software Foundation; either version 2 of the License, or
   9 ;; (at your option) any later version.
  10 ;;
  11 ;; This program is distributed in the hope that it will be useful,
  12 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;; GNU General Public License for more details.
  15 ;;
  16 ;; You should have received a copy of the GNU General Public License along
  17 ;; with this program; if not, write to the Free Software Foundation, Inc.,
  18 ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  19
  20 ;;; Code:
  21
  22 ;; compatibility
  23 (fset 'vm-pop-md5 'vm-md5-string)
  24
  25 ;;;###autoload
  26 (defun vm-md5-region (start end)
  27   (if (fboundp 'md5)
  28       (md5 (current-buffer) start end)
  29     (let ((buffer nil)
  30           (retval nil)
  31           (curbuf (current-buffer)))
  32       (unwind-protect
  33           (save-excursion
  34             (setq buffer (vm-make-work-buffer))
  35             (set-buffer buffer)
  36             (insert-buffer-substring curbuf start end)
  37             ;; call-process-region calls write-region.
  38             ;; don't let it do CR -> LF translation.
  39             (setq selective-display nil)
  40             (setq retval
  41                   (call-process-region (point-min) (point-max)
  42                                        vm-pop-md5-program
  43                                        t buffer nil))
  44             (if (not (equal retval 0))
  45                 (progn
  46                   (error "%s failed: exited with code %s"
  47                          vm-pop-md5-program retval)))
  48             ;; md5sum generates extra output even when summing stdin.
  49             (goto-char (point-min))
  50             (if (re-search-forward " [ *]?-\n" nil t)
  51                 (replace-match ""))
  52
  53             (goto-char (point-min))
  54             (if (or (re-search-forward "[^0-9a-f\n]" nil t)
  55                     (< (point-max) 32))
  56                 (error "%s produced bogus MD5 digest '%s'"
  57                        vm-pop-md5-program
  58                        (vm-buffer-substring-no-properties (point-min)
  59                                                           (point-max))))
  60             ;; MD5 digest is 32 chars long
  61             ;; mddriver adds a newline to make neaten output for tty
  62             ;; viewing, make sure we leave it behind.
  63             (vm-buffer-substring-no-properties (point-min) (+ (point-min) 32)))
  64         (and buffer (kill-buffer buffer))))))
  65
  66 ;; output is in hex
  67 ;;;###autoload
  68 (defun vm-md5-string (string)
  69   (if (fboundp 'md5)
  70       (md5 string)
  71     (vm-with-string-as-temp-buffer
  72      string (function
  73              (lambda ()
  74                (goto-char (point-min))
  75                (insert (vm-md5-region (point-min) (point-max)))
  76                (delete-region (point) (point-max)))))))
  77
  78 ;; output is the raw digest bits, not hex
  79 ;;;###autoload
  80 (defun vm-md5-raw-string (s)
  81   (setq s (vm-md5-string s))
  82   (let ((raw (make-string 16 0))
  83         (i 0) n
  84         (hex-digit-alist '((?0 .  0)  (?1 .  1)  (?2 .  2)  (?3 .  3)
  85                            (?4 .  4)  (?5 .  5)  (?6 .  6)  (?7 .  7)
  86                            (?8 .  8)  (?9 .  9)  (?A . 10)  (?B . 11)
  87                            (?C . 12)  (?D . 13)  (?E . 14)  (?F . 15)
  88                            ;; some mailer uses lower-case hex
  89                            ;; digits despite this being forbidden
  90                            ;; by the MIME spec.
  91                            (?a . 10)  (?b . 11)  (?c . 12)  (?d . 13)
  92                            (?e . 14)  (?f . 15))))
  93     (while (< i 32)
  94       (setq n (+ (* (cdr (assoc (aref s i) hex-digit-alist)) 16)
  95                  (cdr (assoc (aref s (1+ i)) hex-digit-alist))))
  96       (aset raw (/ i 2) n)
  97       (setq i (+ i 2)))
  98     raw ))
  99
 100 ;;;###autoload
 101 (defun vm-xor-string (s1 s2)
 102   (let ((len (length s1))
 103         result (i 0))
 104     (if (/= len (length s2))
 105         (error "strings not of equal length"))
 106     (setq result (make-string len 0))
 107     (while (< i len)
 108       (aset result i (logxor (aref s1 i) (aref s2 i)))
 109       (setq i (1+ i)))
 110     result ))
 111
 112 ;;;###autoload
 113 (defun vm-setup-ssh-tunnel (host port)
 114   (let (local-port process done)
 115     (while (not done)
 116       (setq local-port (+ 1025 (random (- 65536 1025)))
 117             process nil)
 118       (condition-case nil
 119           (progn
 120             (setq process
 121                   (open-network-stream "TEST-CONNECTION" nil
 122                                        "127.0.0.1" local-port))
 123             (process-kill-without-query process))
 124         (error nil))
 125       (cond ((null process)
 126              (setq process
 127                    (apply 'start-process
 128                           (format "SSH tunnel to %s:%s" host port)
 129                           (vm-make-work-buffer)
 130                           vm-ssh-program
 131                           (nconc
 132                            (list "-L"
 133                                  (format "%d:%s:%s" local-port host port))
 134                            (copy-sequence vm-ssh-program-switches)
 135                            (list host vm-ssh-remote-command)))
 136                    done t)
 137              (process-kill-without-query process)
 138              (set-process-sentinel process 'vm-process-sentinel-kill-buffer))
 139             (t
 140              (delete-process process))))
 141
 142     ;; wait for some output from vm-ssh-remote-command.  this
 143     ;; ensures that when we return the ssh connection is ready to
 144     ;; do port-forwarding.
 145     (accept-process-output process)
 146
 147     local-port ))
 148
 149 (defun vm-generate-random-data-file (n-octets)
 150   (let ((file (vm-make-tempfile))
 151         work-buffer (i n-octets))
 152     (unwind-protect
 153         (save-excursion
 154           (setq work-buffer (vm-make-work-buffer))
 155           (set-buffer work-buffer)
 156           (while (> i 0)
 157             (insert-char (random 256) 1)
 158             (setq i (1- i)))
 159           (write-region (point-min) (point-max) file nil 0))
 160       (and work-buffer (kill-buffer work-buffer)))
 161     file ))
 162
 163 ;;;###autoload
 164 (defun vm-setup-stunnel-random-data-if-needed ()
 165   (cond ((null vm-stunnel-random-data-method) nil)
 166         ((eq vm-stunnel-random-data-method 'generate)
 167          (if (and (stringp vm-stunnel-random-data-file)
 168                   (file-readable-p vm-stunnel-random-data-file))
 169              nil
 170            (setq vm-stunnel-random-data-file
 171                  (vm-generate-random-data-file (* 4 1024)))))))
 172
 173 ;;;###autoload
 174 (defun vm-tear-down-stunnel-random-data ()
 175   (if (stringp vm-stunnel-random-data-file)
 176       (vm-error-free-call 'delete-file vm-stunnel-random-data-file))
 177   (setq vm-stunnel-random-data-file nil))
 178
 179 (defun vm-stunnel-random-data-args ()
 180   (cond ((null vm-stunnel-random-data-method) nil)
 181         ((eq vm-stunnel-random-data-method 'generate)
 182          (list "-R" vm-stunnel-random-data-file))
 183         (t nil)))
 184
 185 ;;;###autoload
 186 (defun vm-stunnel-configuration-args (host port)
 187   (if (eq vm-stunnel-wants-configuration-file 'unknown)
 188       (setq vm-stunnel-wants-configuration-file
 189             (not (eq (call-process vm-stunnel-program nil nil nil "-h") 0))))
 190   (if (not vm-stunnel-wants-configuration-file)
 191       (nconc (vm-stunnel-random-data-args)
 192              (list "-W" "-c" "-r"
 193                    (format "%s:%s" host port)))
 194     (let ((work-buffer nil)
 195           (workfile (vm-stunnel-configuration-file)))
 196       (unwind-protect
 197           (save-excursion
 198             (setq work-buffer (vm-make-work-buffer))
 199             (set-buffer work-buffer)
 200             (if (and vm-stunnel-program-additional-configuration-file
 201                      (stringp vm-stunnel-program-additional-configuration-file)
 202                      (file-readable-p
 203                       vm-stunnel-program-additional-configuration-file))
 204                 (insert-file-contents
 205                  vm-stunnel-program-additional-configuration-file))
 206             (insert "client = yes\n")
 207             (insert "RNDfile = " vm-stunnel-random-data-file "\n")
 208             (insert "RNDoverwrite = no\n")
 209             (insert "connect = " (format "%s:%s" host port) "\n")
 210             (write-region (point-min) (point-max) workfile nil 0))
 211         (and work-buffer (kill-buffer work-buffer)))
 212       (list workfile) )))
 213
 214 (defun vm-stunnel-configuration-file ()
 215   (if vm-stunnel-configuration-file
 216       vm-stunnel-configuration-file
 217     (setq vm-stunnel-configuration-file (vm-make-tempfile))
 218     (vm-register-global-garbage-files (list vm-stunnel-configuration-file))
 219     vm-stunnel-configuration-file))
 220
 221 (provide 'vm-crypto)
 222
 223 ;;; vm-crypto.el ends here