mime-mc.el

   1 ;;; mime-mc.el --- Mailcrypt interface for SEMI
   2
   3 ;; Copyright (C) 1996,1997,1998,1999 MORIOKA Tomohiko
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;;         Katsumi Yamaoka  <yamaoka@jpl.org>
   7 ;; Keywords: PGP, GnuPG, security, MIME, multimedia, mail, news
   8
   9 ;; This file is part of SEMI (Secure Emacs MIME Interface).
  10
  11 ;; This program is free software; you can redistribute it and/or
  12 ;; modify it under the terms of the GNU General Public License as
  13 ;; published by the Free Software Foundation; either version 2, or (at
  14 ;; your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; 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; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Code:
  27
  28 (require 'mailcrypt)
  29 (eval-and-compile
  30   (load "mc-pgp")
  31   (load "mc-pgp5" t)
  32   (load "mc-gpg" t)
  33   )
  34
  35 (defun mime-mc-pgp-generic-parser (result)
  36   (let ((ret (mc-pgp-generic-parser result)))
  37     (if (consp ret)
  38         (vector (car ret)(cdr ret))
  39       )))
  40
  41 (defun mime-mc-process-region
  42   (beg end passwd program args parser &optional buffer boundary)
  43   (let ((obuf (current-buffer))
  44         (process-connection-type nil)
  45         mybuf result rgn proc)
  46     (unwind-protect
  47         (progn
  48           (setq mybuf (or buffer (generate-new-buffer " *mailcrypt temp")))
  49           (set-buffer mybuf)
  50           (erase-buffer)
  51           (set-buffer obuf)
  52           (buffer-disable-undo mybuf)
  53           (setq proc
  54                 (apply 'start-process "*PGP*" mybuf program args))
  55           (if passwd
  56               (progn
  57                 (process-send-string proc (concat passwd "\n"))
  58                 (or mc-passwd-timeout (mc-deactivate-passwd t))))
  59           (process-send-region proc beg end)
  60           (process-send-eof proc)
  61           (while (eq 'run (process-status proc))
  62             (accept-process-output proc 5))
  63           (setq result (process-exit-status proc))
  64           ;; Hack to force a status_notify() in Emacs 19.29
  65           (delete-process proc)
  66           (set-buffer mybuf)
  67           (goto-char (point-max))
  68           (if (re-search-backward "\nProcess \\*PGP.*\n\\'" nil t)
  69               (delete-region (match-beginning 0) (match-end 0)))
  70           (goto-char (point-min))
  71           ;; CRNL -> NL
  72           (while (search-forward "\r\n" nil t)
  73             (replace-match "\n"))
  74           ;; Hurm.  FIXME; must get better result codes.
  75           (if (stringp result)
  76               (error "%s exited abnormally: '%s'" program result)
  77             (setq rgn (funcall parser result))
  78             ;; If the parser found something, migrate it
  79             (if (consp rgn)
  80                 (progn
  81                   (set-buffer obuf)
  82                   (if boundary
  83                       (save-restriction
  84                         (narrow-to-region beg end)
  85                         (goto-char beg)
  86                         (insert (format "--%s\n" boundary))
  87                         (goto-char (point-max))
  88                         (insert (format "\n--%s
  89 Content-Type: application/pgp-signature
  90 Content-Transfer-Encoding: 7bit
  91
  92 " boundary))
  93                         (insert-buffer-substring mybuf (car rgn) (cdr rgn))
  94                         (goto-char (point-max))
  95                         (insert (format "\n--%s--\n" boundary))
  96                         )
  97                     (delete-region beg end)
  98                     (goto-char beg)
  99                     (insert-buffer-substring mybuf (car rgn) (cdr rgn))
 100                     )
 101                   (set-buffer mybuf)
 102                   (delete-region (car rgn) (cdr rgn)))))
 103           ;; Return nil on failure and exit code on success
 104           (if rgn result))
 105       ;; Cleanup even on nonlocal exit
 106       (if (and proc (eq 'run (process-status proc)))
 107           (interrupt-process proc))
 108       (set-buffer obuf)
 109       (or buffer (null mybuf) (kill-buffer mybuf)))))
 110
 111 (defun mime-mc-pgp-sign-region (start end &optional id unclear boundary)
 112   (let ((process-environment process-environment)
 113         (buffer (get-buffer-create mc-buffer-name))
 114         (parser (function mc-pgp-generic-parser))
 115         pgp-path key args prompt passwd hash-function)
 116     (cond
 117      ((eq 'mc-scheme-gpg mc-default-scheme)
 118       (setq pgp-path mc-gpg-path
 119             key (mc-gpg-lookup-key (or id mc-gpg-user-id))
 120             args (delq nil
 121                        (nconc
 122                         (if mc-gpg-comment
 123                             (list "--comment" (format "%s" mc-gpg-comment)))
 124                         (list
 125                          (if boundary
 126                              "--detach-sign"
 127                            (if unclear
 128                                "--sign"
 129                              "--clearsign"))
 130                          "--armor" "--batch" "--textmode" "--verbose"
 131                          "--passphrase-fd" "0" "--local-user" (cdr key))))
 132             prompt (format "GnuPG passphrase for %s (%s): "
 133                            (car key) (cdr key))
 134             hash-function 'sha1)
 135       (if (and boundary
 136                (string-match "^pgp-" boundary))
 137           (setq boundary
 138                 (concat "gpg-" (substring boundary (match-end 0))))
 139         ))
 140      ((eq 'mc-scheme-pgp50 mc-default-scheme)
 141       (setq pgp-path mc-pgp50-pgps-path
 142             key (mc-pgp50-lookup-key (or id mc-pgp50-user-id))
 143             args (delq nil
 144                        (list
 145                         (if mc-pgp50-comment
 146                             (format "+comment=%s" mc-pgp50-comment))
 147                         (if boundary
 148                             "-fbat"
 149                           "-fat")
 150                         "+verbose=1" "+language=us"
 151                         (format "+clearsig=%s" (if unclear "off" "on"))
 152                         "+batchmode" "-u" (cdr key)))
 153             prompt (format "PGP passphrase for %s (%s): "
 154                            (car key) (cdr key))
 155             hash-function 'md5)
 156       (setenv "PGPPASSFD" "0")
 157       )
 158      (t
 159       (setq pgp-path mc-pgp-path
 160             key (mc-pgp-lookup-key (or id mc-pgp-user-id))
 161             args (delq nil
 162                        (list
 163                         (if mc-pgp-comment
 164                             (format "+comment=%s" mc-pgp-comment))
 165                         (if boundary
 166                             "-fbast"
 167                           "-fast")
 168                         "+verbose=1" "+language=en"
 169                         (format "+clearsig=%s" (if unclear "off" "on"))
 170                         "+batchmode" "-u" (cdr key)))
 171             prompt (format "PGP passphrase for %s (%s): "
 172                            (car key) (cdr key))
 173             hash-function 'md5)
 174       (setenv "PGPPASSFD" "0")
 175       ))
 176     (setq passwd (mc-activate-passwd (cdr key) prompt))
 177     (message "Signing as %s ..." (car key))
 178     (if (mime-mc-process-region
 179          start end passwd pgp-path args parser buffer boundary)
 180         (progn
 181           (if boundary
 182               (progn
 183                 (goto-char (point-min))
 184                 (insert
 185                  (format "\
 186 --[[multipart/signed; protocol=\"application/pgp-signature\";
 187  boundary=\"%s\"; micalg=pgp-%s][7bit]]\n"
 188                          boundary hash-function))
 189                 ))
 190           (message "Signing as %s ... Done." (car key))
 191           t)
 192       nil)))
 193
 194 (defun mime-mc-pgp-encrypt-region (recipients start end &optional id sign)
 195   (let ((mc-pgp-always-sign (if (eq sign 'maybe)
 196                                 mc-pgp-always-sign
 197                               'never))
 198         (function (cond ((eq 'mc-scheme-gpg mc-default-scheme)
 199                          'mc-gpg-encrypt-region)
 200                         ((eq 'mc-scheme-pgp50 mc-default-scheme)
 201                          'mc-pgp50-encrypt-region)
 202                         (t
 203                          'mc-pgp-encrypt-region))))
 204     (funcall function
 205              (mc-split "\\([ \t\n]*,[ \t\n]*\\)+" recipients)
 206              start end id nil)
 207     ))
 208
 209
 210 ;;; @ end
 211 ;;;
 212
 213 (provide 'mime-mc)
 214
 215 ;;; mime-mc.el ends here