X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=pgg.el;h=2b4257c7a2cd7d67a1d7bafb5e946637ea8dc778;hb=d6855c5e8828e26638ea79bab7f9835e93c771fa;hp=f33f0fb35449a64ae678aeeb16aad09c95fbc0fb;hpb=a378d15f7c8694c8708e3215ef0adde347a82d33;p=elisp%2Fsemi.git diff --git a/pgg.el b/pgg.el index f33f0fb..2b4257c 100644 --- a/pgg.el +++ b/pgg.el @@ -23,6 +23,10 @@ ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; + ;;; Code: (require 'calist) @@ -33,7 +37,7 @@ (require 'pgg-parse) (eval-when-compile - (ignore-errors + (ignore-errors (require 'w3) (require 'url))) @@ -120,37 +124,157 @@ (luna-define-generic decrypt-region (scheme start end) "Decrypt the current region between START and END.") -(luna-define-generic sign-region (scheme start end) +(luna-define-generic sign-region (scheme start end &optional cleartext) "Make detached signature from text between START and END.") (luna-define-generic verify-region (scheme start end &optional signature) - "Verify region between START and END + "Verify region between START and END as the detached signature SIGNATURE.") (luna-define-generic insert-key (scheme) "Insert public key at point.") (luna-define-generic snarf-keys-region (scheme start end) - "Add all public keys in region between START + "Add all public keys in region between START and END to the keyring.") -;;; @ interface functions +;;; @ utility functions ;;; +(defvar pgg-fetch-key-function (function pgg-fetch-key-with-w3)) + (defmacro pgg-make-scheme (scheme) `(progn (require (intern (format "pgg-%s" ,scheme))) - (funcall (intern (format "pgg-make-scheme-%s" + (funcall (intern (format "pgg-make-scheme-%s" ,scheme))))) +(put 'pgg-save-coding-system 'lisp-indent-function 2) + +(defmacro pgg-save-coding-system (start end &rest body) + `(if (interactive-p) + (let ((buffer (current-buffer))) + (with-temp-buffer + (let (buffer-undo-list) + (insert-buffer-substring buffer ,start ,end) + (encode-coding-region (point-min)(point-max) + buffer-file-coding-system) + (prog1 (save-excursion ,@body) + (push nil buffer-undo-list) + (ignore-errors (undo))) + ))) + (save-restriction + (narrow-to-region ,start ,end) + ,@body))) + +(defun pgg-temp-buffer-show-function (buffer) + (if (one-window-p (selected-window)) + (let ((window (split-window-vertically + (- (window-height) + (/ (window-height) 5))))) + (set-window-buffer window buffer)) + (display-buffer buffer))) + +(defun pgg-display-output-buffer (start end status) + (if status + (progn + (delete-region start end) + (insert-buffer-substring pgg-output-buffer) + (decode-coding-region start (point) buffer-file-coding-system) + ) + (let ((temp-buffer-show-function + (function pgg-temp-buffer-show-function))) + (with-output-to-temp-buffer pgg-echo-buffer + (set-buffer standard-output) + (insert-buffer-substring pgg-errors-buffer))) + )) + +(defvar pgg-passphrase-cache-expiry 16) +(defvar pgg-passphrase-cache (make-vector 7 0)) + +(defvar pgg-read-passphrase nil) +(defun pgg-read-passphrase (prompt &optional key) + (if (not pgg-read-passphrase) + (if (functionp 'read-passwd) + (setq pgg-read-passphrase 'read-passwd) + (if (load "passwd" t) + (setq pgg-read-passphrase 'read-passwd) + (autoload 'ange-ftp-read-passwd "ange-ftp") + (setq pgg-read-passphrase 'ange-ftp-read-passwd)))) + (or (and pgg-cache-passphrase + key (setq key (pgg-truncate-key-identifier key)) + (symbol-value (intern-soft key pgg-passphrase-cache))) + (funcall pgg-read-passphrase prompt))) + +(defun pgg-add-passphrase-cache (key passphrase) + (setq key (pgg-truncate-key-identifier key)) + (set (intern key pgg-passphrase-cache) + passphrase) + (run-at-time pgg-passphrase-cache-expiry nil + #'pgg-remove-passphrase-cache + key)) + +(defun pgg-remove-passphrase-cache (key) + (let ((passphrase (symbol-value (intern key pgg-passphrase-cache)))) + (fillarray passphrase ?_) + (let ((obarray pgg-passphrase-cache)) + (makunbound key)) + (unintern key pgg-passphrase-cache))) + +(defmacro pgg-convert-lbt-region (start end lbt) + `(let ((pgg-conversion-end (set-marker (make-marker) ,end))) + (goto-char ,start) + (case ,lbt + (CRLF + (while (progn + (end-of-line) + (> (marker-position pgg-conversion-end) (point))) + (insert "\r") + (forward-line 1))) + (LF + (while (re-search-forward "\r$" pgg-conversion-end t) + (replace-match "")))) + )) + +(put 'pgg-as-lbt 'lisp-indent-function 3) + +(defmacro pgg-as-lbt (start end lbt &rest body) + `(let ((inhibit-read-only t) + buffer-read-only + buffer-undo-list) + (pgg-convert-lbt-region ,start ,end ,lbt) + (let ((,end (point))) + ,@body) + (push nil buffer-undo-list) + (ignore-errors (undo)))) + +(put 'pgg-process-when-success 'lisp-indent-function 0) + +(defmacro pgg-process-when-success (&rest body) + `(with-current-buffer pgg-output-buffer + (if (zerop (buffer-size)) nil ,@body t))) + + +;;; @ interface functions +;;; + +;;;###autoload (defun pgg-encrypt-region (start end rcpts) + "Encrypt the current region between START and END for RCPTS." (interactive (list (region-beginning)(region-end) (split-string (read-string "Recipients: ") "[ \t,]+"))) - (let ((entity (pgg-make-scheme pgg-default-scheme))) - (luna-send entity 'encrypt-region entity start end rcpts))) - + (let* ((entity (pgg-make-scheme pgg-default-scheme)) + (status (pgg-save-coding-system start end + (luna-send entity 'encrypt-region entity + (point-min)(point-max) rcpts)))) + (when (interactive-p) + (pgg-display-output-buffer start end status)) + status)) + +;;;###autoload (defun pgg-decrypt-region (start end) + "Decrypt the current region between START and END." (interactive "r") (let* ((packet (cdr (assq 1 (pgg-parse-armor-region start end)))) (scheme @@ -161,23 +285,46 @@ and END to the keyring.") (ctree-match-calist pgg-decrypt-condition packet)))) pgg-default-scheme)) - (entity (pgg-make-scheme scheme))) - (luna-send entity 'decrypt-region entity start end))) - -(defun pgg-sign-region (start end) + (entity (pgg-make-scheme scheme)) + (status (pgg-save-coding-system start end + (luna-send entity 'decrypt-region entity + (point-min)(point-max))))) + (when (interactive-p) + (pgg-display-output-buffer start end status)) + status)) + +;;;###autoload +(defun pgg-sign-region (start end &optional cleartext) + "Make the signature from text between START and END. +If the optional 3rd argument CLEARTEXT is non-nil, it does not create +a detached signature." (interactive "r") - (let ((entity (pgg-make-scheme pgg-default-scheme))) - (luna-send entity 'sign-region entity start end))) - + (let* ((entity (pgg-make-scheme pgg-default-scheme)) + (status (pgg-save-coding-system start end + (luna-send entity 'sign-region entity + (point-min)(point-max) + (or (interactive-p) cleartext))))) + (when (interactive-p) + (pgg-display-output-buffer start end status)) + status)) + +;;;###autoload (defun pgg-verify-region (start end &optional signature fetch) + "Verify the current region between START and END. +If the optional 3rd argument SIGNATURE is non-nil, it is treated as +the detached signature of the current region. + +If the optional 4th argument FETCH is non-nil, we attempt to fetch the +signer's public key from `pgg-default-keyserver-address'." (interactive "r") (let* ((packet - (with-temp-buffer - (buffer-disable-undo) - (set-buffer-multibyte nil) - (insert-file-contents signature) - (cdr (assq 2 (pgg-decode-armor-region (point-min)(point-max)))) - )) + (if (null signature) nil + (with-temp-buffer + (buffer-disable-undo) + (set-buffer-multibyte nil) + (insert-file-contents signature) + (cdr (assq 2 (pgg-decode-armor-region (point-min)(point-max)))) + ))) (scheme (or pgg-scheme (cdr (assq 'scheme @@ -188,96 +335,100 @@ and END to the keyring.") pgg-default-scheme)) (entity (pgg-make-scheme scheme)) (key (cdr (assq 'key-identifier packet))) - keyserver) + status keyserver) (and (stringp key) (setq key (concat "0x" (pgg-truncate-key-identifier key))) - (null (pgg-lookup-key-string key)) - fetch + (null (let ((pgg-scheme scheme)) + (pgg-lookup-key-string key))) + (or fetch (interactive-p)) (y-or-n-p (format "Key %s not found; attempt to fetch? " key)) - (setq keyserver + (setq keyserver (or (cdr (assq 'preferred-key-server packet)) pgg-default-keyserver-address)) - (ignore-errors - (require 'url) - (pgg-fetch-key - (if (url-type (url-generic-parse-url keyserver)) - keyserver - (format "http://%s:11371/pks/lookup?op=get&search=%s" - keyserver key))))) - (luna-send entity 'verify-region entity start end signature))) - + (pgg-fetch-key keyserver key)) + (setq status (pgg-save-coding-system start end + (luna-send entity 'verify-region entity + (point-min)(point-max) signature))) + (when (interactive-p) + (let ((temp-buffer-show-function + (function pgg-temp-buffer-show-function))) + (with-output-to-temp-buffer pgg-echo-buffer + (set-buffer standard-output) + (insert-buffer-substring (if status pgg-output-buffer + pgg-errors-buffer)) + ))) + status)) + +;;;###autoload (defun pgg-insert-key () + "Insert the ASCII armored public key." + (interactive) (let ((entity (pgg-make-scheme (or pgg-scheme pgg-default-scheme)))) (luna-send entity 'insert-key entity))) +;;;###autoload (defun pgg-snarf-keys-region (start end) + "Import public keys in the current region between START and END." + (interactive "r") (let ((entity (pgg-make-scheme (or pgg-scheme pgg-default-scheme)))) - (luna-send entity 'snarf-keys-region entity start end))) + (pgg-save-coding-system start end + (luna-send entity 'snarf-keys-region entity start end)))) (defun pgg-lookup-key-string (string &optional type) (let ((entity (pgg-make-scheme (or pgg-scheme pgg-default-scheme)))) (luna-send entity 'lookup-key-string entity string type))) -(defun pgg-fetch-key (url) - "Attempt to fetch a key for addition to PGP or GnuPG keyring. +(defvar pgg-insert-url-function (function pgg-insert-url-with-w3)) -Return t if we think we were successful; nil otherwise. Note that nil -is not necessarily an error, since we may have merely fired off an Email -request for the key." +(defun pgg-insert-url-with-w3 (url) (require 'w3) (require 'url) + (let (buffer-file-name) + (url-insert-file-contents url))) + +(defvar pgg-insert-url-extra-arguments nil) +(defvar pgg-insert-url-program nil) + +(defun pgg-insert-url-with-program (url) + (let ((args (copy-sequence pgg-insert-url-extra-arguments)) + process) + (insert + (with-temp-buffer + (setq process + (apply #'start-process " *PGG url*" (current-buffer) + pgg-insert-url-program (nconc args (list url)))) + (set-process-sentinel process #'ignore) + (while (eq 'run (process-status process)) + (accept-process-output process 5)) + (delete-process process) + (if (and process (eq 'run (process-status process))) + (interrupt-process process)) + (buffer-string))) + )) + +(defun pgg-fetch-key (keyserver key) + "Attempt to fetch a KEY from KEYSERVER for addition to PGP or GnuPG keyring." (with-current-buffer (get-buffer-create pgg-output-buffer) (buffer-disable-undo) (erase-buffer) - (let ((proto (url-type (url-generic-parse-url url))) - buffer-file-name) - (unless (memq (intern proto) '(http finger)) - (insert (format "Protocol %s is not supported.\n" proto))) - (url-insert-file-contents url) - (if (re-search-forward "^-+BEGIN" nil 'last) - (progn - (delete-region (point-min) (match-beginning 0)) - (when (re-search-forward "^-+END" nil t) - (delete-region (progn (end-of-line) (point)) - (point-max))) - (insert "\n") - (with-temp-buffer - (insert-buffer-substring pgg-output-buffer) - (pgg-snarf-keys-region (point-min)(point-max)))) - (erase-buffer) - (insert "Cannot retrieve public key from URL (" url ")\n"))) - )) - - -;;; @ utility functions -;;; - -(defvar pgg-passphrase-cache-expiry 16) -(defvar pgg-passphrase-cache (make-vector 7 0)) - -(defvar pgg-read-passphrase nil) -(defun pgg-read-passphrase (prompt &optional key) - (if (not pgg-read-passphrase) - (if (functionp 'read-passwd) - (setq pgg-read-passphrase 'read-passwd) - (if (load "passwd" t) - (setq pgg-read-passphrase 'read-passwd) - (autoload 'ange-ftp-read-passwd "ange-ftp") - (setq pgg-read-passphrase 'ange-ftp-read-passwd)))) - (or (and key (setq key (pgg-truncate-key-identifier key)) - (symbol-value (intern-soft key pgg-passphrase-cache))) - (funcall pgg-read-passphrase prompt))) + (let ((proto (if (string-match "^[a-zA-Z\\+\\.\\\\-]+:" keyserver) + (substring keyserver 0 (1- (match-end 0)))))) + (save-excursion + (funcall pgg-insert-url-function + (if proto keyserver + (format "http://%s:11371/pks/lookup?op=get&search=%s" + keyserver key)))) + (when (re-search-forward "^-+BEGIN" nil 'last) + (delete-region (point-min) (match-beginning 0)) + (when (re-search-forward "^-+END" nil t) + (delete-region (progn (end-of-line) (point)) + (point-max))) + (insert "\n") + (with-temp-buffer + (insert-buffer-substring pgg-output-buffer) + (pgg-snarf-keys-region (point-min)(point-max)))) + ))) -(defun pgg-add-passphrase-cache (key passphrase) - (setq key (pgg-truncate-key-identifier key)) - (set (intern key pgg-passphrase-cache) - passphrase) - (run-at-time pgg-passphrase-cache-expiry nil - #'pgg-remove-passphrase-cache - key)) - -(defun pgg-remove-passphrase-cache (key) - (unintern key pgg-passphrase-cache)) (provide 'pgg)