;;; $Id: pgp.el,v 1.13 2006/10/29 17:35:10 pem Exp $
;;;
;;; Per-Erik Martin (pem@pem.nu) 2001-01-27, 2002-07-19, 2002-11-28, 2002-12-03
;;;   2004-05-29, 2006-10-29.
;;;
;;; PGP and GnuGP support for the VM mailer in Emacs v19-21.
;;;
;;; See pgp-vm-doc.txt for documentation.
;;;

;;; This program requires both sendmail.el and vm.el:
;;;
;;; The sendmail variable mail-header-separator is used.
;;; The pgp-vm-verify-signature function is entirerly VM dependent.

;;; ------------------------------------------------------------------
;;; Configurables
;;;

(defconst pgp-vm-version "2.2.2")

(defvar pgp-tmp-directory "/tmp/" "\
*The directory where incoming emails are saved temporarily while
verifying a signature. Files are removed after verification, but
you may want to make sure this is somewhere private anyway.")

(defvar pgp-program "/usr/local/bin/pgp" "\
*The command line PGP program. If it is not an explicit path, it
must be found in the PATH of the caller.")

(defvar gpg-program "/usr/local/bin/gpg" "\
*The command line GnuPG program. If it is not an explicit path, it
must be found in the PATH of the caller.")


;;; ------------------------------------------------------------------
;;; Signing/verification
;;;

;;; Sign the current buffer (assumed to be a vm-mail buffer).
(defun pgp-vm-sign ()
"Sign the current composed message using PGP. The program to call
is set in the variable pgp-program."
  (interactive)
  (pem-vm-sign 'pgp-sign-call "pgp-md5"))

(defun gpg-vm-sign ()
"Sign the current composed message using Gnu PG. The program to call
is set in the variable gpg-program."
  (interactive)
  (pem-vm-sign 'gpg-sign-call "pgp-sha1"))

(defun pem-vm-sign (signer micalg)
  ;; We do everything in a temporary buffer. If something goes wrong,
  ;; the buffer is left intact.
  (let ((curbuf (current-buffer))
	(tmpbuf (get-buffer-create (concat " *pgp-sign-temp*"))))
    (unwind-protect
	 (save-excursion
	   (condition-case x
	       (vm-mime-encode-composition)
	     (error
	      (if (not (string= (nth 1 x) "Message is already MIME encoded."))
		  (error (nth 1 x)))))
	   (set-buffer tmpbuf)
	   (insert-buffer curbuf)	;Copy original
	   (cond ((pem-sign signer micalg)
		  ;; Successful. Replace the old contents.
		  (set-buffer curbuf)
		  (delete-region (point-min) (point-max))
		  (insert-buffer tmpbuf)
		  (message "Signed. C-c C-c to send, C-x u to undo"))
		 (t (error "Signing failed"))))
      (kill-buffer tmpbuf))))

;;; Signs the current message buffer.
;;; Returns t on success, nil otherwise.
(defun pem-sign (signer micalg)
  (goto-char (point-min))
  (let* ((header-sep (concat "^" mail-header-separator "$"))
	 (end-of-head (re-search-forward header-sep (point-max) t)))
    (if (null end-of-head)
	(error "End of header not found")
	(let* ((b (pem-mime-make-multipart-boundary))
	       (mpb (concat "\n--" b))
	       (case-fold-search nil))
	  ;; If there's no MIME-Version:, insert one.
	  (if (null (pem-get-header-val "^MIME-Version: "
					(point-min) end-of-head))
	      (insert "MIME-Version: 1.0\n"))
	  ;; Find Content-Type:
	  (let* ((oldct (pem-get-header-val "^Content-Type: "
					    (point-min) end-of-head t))
		 (insct (null oldct)))	;t if we'll insert a new Content-Type
	    (cond (insct
		   (insert "Content-Type: ")
		   (setq oldct "text/plain; charset=us-ascii")))
	    ;; We set an arbitrary micalg field, PGP doesn't use it.
	    (insert (concat "multipart/signed; boundary="
			    b
			    (concat "; micalg=" micalg)
			    ";\n\tprotocol=\"application/pgp-signed\""))
	    (if insct
		(insert-char ?\n 1))
	    ;; Find Content-Transfer-Encoding:
	    ;; First find the end again, since we have been editing.
	    (goto-char (point-min))
	    (setq end-of-head (re-search-forward header-sep (point-max) t))
	    (let ((oldcte (pem-get-header-val "^Content-Transfer-Encoding: "
					      (point-min) end-of-head t)))
	      (cond (oldcte
		     (pem-delete-whole-line)))
	      ;; Now work on the body.
	      ;; Have to find it again...
	      (goto-char (point-min))
	      (setq end-of-head (re-search-forward header-sep (point-max) t))
	      (beginning-of-line 2)
	      (insert mpb)		;Insert the multipart boundary
	      (newline)
	      (let ((p1 (point)))
		(open-line 1)
		(insert "Content-Type: ")
		(insert oldct)
		(newline)
		(if oldcte
		    (progn
		      (insert "Content-Transfer-Encoding: ")
		      (insert oldcte)
		      (newline)))
		(pem-canonicalization p1 t) ;LF->CRLF and From conversion
		;; Now add the signature part at the end.
		(goto-char (point-max))
		;; We will sign from p1 to p2
		(let ((p2 (point))
		      res)
		  (insert mpb)
		  (newline)
		  (insert "Content-Type: application/pgp-signature")
		  (newline 2)
		  (setq res (apply signer (list p1 p2))) ;Sign
		  (insert mpb)
		  (insert "--")		;The last one
		  (newline)
		  res))))))))

;;; Verify the currently displayed message in VM.
(defun pgp-vm-verify-signature ()
"Verify the signature of the current VM message, using PGP. The program to call
is set in the variable pgp-program."
  (interactive)
  (pem-vm-verify-signature 'pgp-verify-call))

(defun gpg-vm-verify-signature ()
"Verify the signature of the current VM message, using Gnu PG.
The program to call is set in the variable gpg-program."
  (interactive)
  (pem-vm-verify-signature 'gpg-verify-call))

(defun pem-vm-verify-signature (verifyer)
  (let ((case-fold-search nil)
	(vmbuffers (pem-vm-buffer-name-list)))
    (if (not (member (buffer-name) vmbuffers))
	(error "Current buffer is not a mail buffer")
	(save-excursion
	  (set-buffer (car vmbuffers))
	  (widen)
	  (let ((begm (re-search-backward "^From " (point-min) t)))
	    (if (null begm)
		(error "Message beginning not found")
		(progn
		  (beginning-of-line 2) (setq begm (point))
		  (let ((endm (or
				(re-search-forward "^From " (point-max) t)
				(point-max))))
		    (goto-char begm)
		    (let* ((midm (search-forward "\n\n" endm t))
			   (buf (pem-verify-signature verifyer begm midm endm)))
		      (if buf
			  (display-buffer buf)))))))))))

;;; Verify message between begm and endm in current buffer.
(defun pem-verify-signature (verifyer begm midm endm)
  (let ((ct (pem-get-header-val "^Content-Type: " begm midm)))
    (cond ((null ct)
	   (error "Missing Content-Type"))
	  ((not (pem-is-signed ct))
	   (error "Not PGP signed"))
	  (t (let ((b (pem-get-boundary-regexp ct)))
	       (if (null b)
		   (error "No multipart boundary")
		   (pem-verify-signature-body verifyer b midm endm)))))))

(defun pem-verify-signature-body (verifyer boundary begm endm)
  (goto-char begm)
  (let* ((file1 (make-unique-tmp-file ".pgp-temp-"))
	 (buf1 (pem-get-next-part boundary endm file1))
	 (file2 (concat file1 ".sig"))
	 (buf2 (pem-get-next-part boundary endm file2)))
    (unwind-protect
	 (cond ((null buf1)
		(error "Failed to get the first (message) part"))
	       ((null buf2)
		(error "Failed to get the second (signature) part"))
	       (t
		(set-buffer buf1)
		(pem-canonicalization (point-min))
		(write-file file1)
		(set-file-modes file1 384) ; -rw-------
		(message nil)
		(set-buffer buf2)
		(goto-char (point-min))
		(cond ((null (re-search-forward
			      "^Content-Type: application/pgp-signature$"
			      (point-max) t))
		       (error "Second part is not a PGP signature"))
		      ((null (search-forward "\n\n" (point-max) t))
		       (error "No blank line in signature part"))
		      (t
		       (delete-region (point-min) (point))
		       (message "File2=%s" file2)
		       (write-file file2)
		       (set-file-modes file2 384) ; -rw-------
		       (message nil)
		       (apply verifyer (list file1 file2))))))
      (if buf1
	  (kill-buffer buf1))
      (if buf2
	  (kill-buffer buf2))
      (if (file-exists-p file1)
	  (delete-file file1))
      (if (file-exists-p file2)
	  (delete-file file2)))))


;;; ------------------------------------------------------------------
;;; Encryption/decryption
;;;

;;; Encrypts the current buffer (assumed to be a vm-mail buffer).
(defun pgp-vm-encrypt ()
"Encrypt the current composed message using PGP. The program to call
is set in the variable pgp-program."
  (interactive)
  (pem-vm-encrypt 'pgp-encrypt-call nil))

(defun gpg-vm-encrypt ()
"Encrypt the current composed message using Gnu PG. The program to call
is set in the variable gpg-program."
  (interactive)
  (pem-vm-encrypt 'gpg-encrypt-call nil))

;;; For convenience: Both sign and encrypt.
(defun pgp-vm-both-sign-and-encrypt ()
"Encrypt and sign the current composed message using PGP. The program to call
is set in the variable pgp-program."
  (interactive)
  (pem-vm-encrypt 'pgp-sign-encrypt-call t))

(defun gpg-vm-both-sign-and-encrypt ()
"Encrypt and sign the current composed message using Gnu PG. The program to call
is set in the variable gpg-program."
  (interactive)
  (pem-vm-encrypt 'gpg-sign-encrypt-call t))

;;; Encrypts the current buffer (assumed to be a vm-mail buffer).
(defun pem-vm-encrypt (encryptor sign)
  ;; We do everything in a temporary buffer. If something goes wrong,
  ;; the buffer is left intact.
  (let ((curbuf (current-buffer))
	(tmpbuf (get-buffer-create " *pgp-encr-temp*")))
    (unwind-protect
	 (save-excursion
	   (condition-case x
	       (vm-mime-encode-composition)
	     (error
	      (if (not (string= (nth 1 x) "Message is already MIME encoded."))
		  (error (nth 1 x)))))
	   (set-buffer tmpbuf)
	   (insert-buffer curbuf)	;Copy original
	   (cond ((pem-encrypt encryptor sign)
		  ;; Successful. Replace the old contents.
		  (set-buffer curbuf)
		  (delete-region (point-min) (point-max))
		  (insert-buffer tmpbuf)
		  (message "Encrypted. C-c C-c to send, C-x u to undo"))
		 (t (error "Encryption failed"))))
      (kill-buffer tmpbuf))))

;;; Encrypts the current message buffer.
;;; Returns t on success, nil otherwise.
(defun pem-encrypt (encryptor sign)
  (goto-char (point-min))
  (let* ((header-sep (concat "^" mail-header-separator "$"))
	 (end-of-head (re-search-forward header-sep (point-max) t)))
    (if (null end-of-head)
	(error "End of header not found")
	(let* ((b (pem-mime-make-multipart-boundary))
	       (mpb (concat "\n--" b))
	       (case-fold-search nil)
	       (to-ids nil))
	  ;; If there's no MIME-Version:, insert one.
	  (if (null (pem-get-header-val "^MIME-Version: "
					(point-min) end-of-head))
	      (insert "MIME-Version: 1.0\n"))
	  (setq to-ids (pem-get-recipients (point-min) end-of-head))
	  (cond ((null to-ids)
		 (error "No recipients, can't encrypt"))
		((cdr to-ids)
		 (error
		  "Encrypting for more than one receiver it not supported")))
	  ;; Find Content-Type:
	  (let* ((oldct (pem-get-header-val "^Content-Type: "
					    (point-min) end-of-head t))
		 (insct (null oldct)))	;t if we'll insert a new Content-Type
	    (cond (insct
		   (insert "Content-Type: ")
		   (setq oldct "text/plain; charset=us-ascii")))
	    (insert (concat "multipart/encrypted; boundary="
			    b
			    ";\n\tprotocol=\"application/pgp-encrypted\""))
	    (if insct
		(insert-char ?\n 1))
	    ;; Find Content-Transfer-Encoding:
	    ;; First find the end again, since we have been editing.
	    (goto-char (point-min))
	    (setq end-of-head (re-search-forward header-sep (point-max) t))
	    (let ((oldcte (pem-get-header-val "^Content-Transfer-Encoding: "
					      (point-min) end-of-head t)))
	      (cond (oldcte
		     (pem-delete-whole-line)))
	      ;; Now work on the body.
	      ;; Have to find it again...
	      (goto-char (point-min))
	      (setq end-of-head (re-search-forward header-sep (point-max) t))
	      (beginning-of-line 2)
	      (insert mpb)		;Insert the multipart boundary
	      (newline)
	      (insert "Content-Type: application/pgp-encrypted\n\n")
	      (insert "Version: 1\n")
	      (let ((p1 (point)))
		(open-line 1)
		(insert "Content-Type: ")
		(insert oldct)
		(newline)
		(if oldcte
		    (progn
		      (insert "Content-Transfer-Encoding: ")
		      (insert oldcte)
		      (newline)))
		(if sign
		    (pem-canonicalization p1 t))
		;; Now encrypt the content part at the end (and maybe sign).
		(goto-char (point-max))
		(let ((res (apply encryptor (list (car to-ids) p1 (point)))))
		  (goto-char p1)
		  (insert mpb)
		  (newline)
		  (insert "Content-Type: application/octet-stream")
		  (newline 2)
		  (goto-char (point-max))
		  (insert mpb)
		  (insert "--")		;The last one
		  (newline)
		  res))))))))

;;; Decrypt the currently displayed message in VM.
(defun pgp-vm-decrypt ()
"Decrypt the message of the current VM message, using PGP.
If the message is also signed, the signature is verified as well.
The program to call is set in the variable pgp-program."
  (interactive)
  (pem-vm-decrypt 'pgp-decrypt-call))

(defun gpg-vm-decrypt ()
"Decrypt the message of the current VM message, using Gnu GP.
If the message is also signed, the signature is verified as well.
The program to call is set in the variable gpg-program."
  (interactive)
  (pem-vm-decrypt 'gpg-decrypt-call))

(defun pem-vm-decrypt (decryptor)
  (let ((vmbuffers (pem-vm-buffer-name-list)))
    (if (not (member (buffer-name) vmbuffers))
	(error "Current buffer is not a mail buffer")
	(let ((case-fold-search nil)
	      (oldbuf (current-buffer))
	      (decrypt))
	  (save-excursion
	    (set-buffer (car vmbuffers))
	    (widen)
	    (let ((begm (re-search-backward "^From " (point-min) t)))
	      (if (null begm)
		  (error "Message beginning not found")
		  (progn
		    (beginning-of-line 2) (setq begm (point))
		    (let ((endm (or
				 (re-search-forward "^From " (point-max) t)
				 (point-max))))
		      (goto-char begm)
		      (let ((midm (search-forward "\n\n" endm t)))
			(setq decrypt
			      (pem-decrypt decryptor begm midm endm))))))))
	  (if decrypt
	      (let ((secbuf (if (listp decrypt) (car decrypt) decrypt))
		    (verbuf (if (listp decrypt) (nth 1 decrypt) nil)))
		(set-buffer secbuf)
		(toggle-read-only 0)
		(goto-char (point-min))
		(replace-string "\r\n" "\n") ;...or vm-decode-mime-layout fails.
		(let ((p (point-max)))
		  (goto-char p)
		  (vm-decode-mime-layout
		   (vm-mime-parse-entity nil
					 '("text/plain" "charset=us-ascii")
					 "7bit"))
		  (delete-region (point-min) p)
		  (toggle-read-only 1)
		  (cond (verbuf
			 (display-buffer verbuf)
			 (set-buffer verbuf)
			 (split-window-vertically)
			 (switch-to-buffer-other-window secbuf))
			(t (display-buffer secbuf)))
		  (cond ((y-or-n-p "Kill decryption buffers? ")
			 (kill-buffer secbuf)
			 (if verbuf
			     (kill-buffer verbuf))
			 (switch-to-buffer oldbuf)
			 (delete-other-windows)
			 (vm-summarize))))))))))

;;; Decrypt message between begm and endm in current buffer.
(defun pem-decrypt (decryptor begm midm endm)
  (let ((ct (pem-get-header-val "^Content-Type: " begm midm)))
    (cond ((null ct)
	   (error "Missing Content-Type"))
	  ((not (pem-is-encrypted ct))
	   (error "Not PGP encrypted"))
	  (t (let ((b (pem-get-boundary-regexp ct)))
	       (if (null b)
		   (error "No multipart boundary")
		   (pem-decrypt-body decryptor b midm endm)))))))

(defun pem-decrypt-body (decryptor boundary begm endm)
  (goto-char begm)
  (let* ((bufvers (pem-get-next-part boundary endm " *temp-vers*"))
	 (bufdecr (pem-get-next-part boundary endm " *temp-decr*")))
    (unwind-protect
	 (cond ((null bufvers)
		(error "Failed to get the first (version) part"))
	       ((null bufdecr)
		(error "Failed to get the second (cryptogram) part"))
	       (t
		;;; Check first part
		(set-buffer bufvers)
		(cond ((not (string-equal "application/pgp-encrypted"
					  (pem-get-header-val "Content-Type: "
							      (point-min)
							      (point-max))))
		       (error "First part is not a pgp-encrypt control part"))
		      ((null (search-forward "\n\n" (point-max) t))
		       (error "No blank line in control part"))
		      ((null (search-forward-regexp "^Version: 1$"
						   (point-max) t))
		       (error "First part does not contain Version: 1")))
		;;; Chech second part
		(set-buffer bufdecr)
		(goto-char (point-min))
		(cond ((not (string-equal "application/octet-stream"
					  (pem-get-header-val "^Content-Type: "
							      (point-min)
							      (point-max))))
		       (error "Second part is not a octet-stream"))
		      ((null (search-forward "\n\n" (point-max) t))
		       (error "No blank line in encrypted part"))
		      (t
		       (apply decryptor (list (point) (point-max)))))))
      (if bufvers
	  (kill-buffer bufvers))
      (if bufdecr
	  (kill-buffer bufdecr)))))


;;; ------------------------------------------------------------------
;;; Auxiliary functions
;;;

(defun make-unique-tmp-file (prefix)
  (concat pgp-tmp-directory prefix
	  (user-login-name) (number-to-string (emacs-pid))))

;;; Delete the whole line where point is.
(defun pem-delete-whole-line ()
  (beginning-of-line)
  (let ((p (point)))
    (beginning-of-line 2)		;Beginning of next line
    (delete-region p (point))))

;;; Checks if the Content-Type value starting at point is a "PGP signed".
;;; Returns an integer if it is, nil otherwise.
(defun pem-is-signed (ct)
  (and (string-match "\\<multipart/signed\\>" ct)
       (string-match "\\<protocol *= *\"application/pgp-signed\"" ct)))

;;; Checks if the Content-Type value starting at point is a "PGP encrypted".
;;; Returns an integer if it is, nil otherwise.
(defun pem-is-encrypted (ct)
  (and (string-match "\\<multipart/encrypted\\>" ct)
       (string-match "\\<protocol *= *\"application/pgp-encrypted\"" ct)))

;;; Returns a regexp for the multipart boundary.
;;; Point must be at the beginning of a Content-Type value.
;;; Returns nil if no boundary is found.
(defun pem-get-boundary-regexp (ct)
  (if (string-match "\\<boundary *= *\\([^ \t\n\r;]+\\)" ct)
      (concat "^--"
	      (regexp-quote (substring ct (match-beginning 1) (match-end 1)))
	      "-*$")))

;;; Returns a list of the recipients.
(defun pem-get-recipients (beg end)
  (pem-list-recipients
   (pem-get-header-val "^To: " beg end)
   (pem-list-recipients
    (pem-get-header-val "^Cc: " beg end)
    (pem-list-recipients
     (pem-get-header-val "^Bcc: " beg end)))))

(defun pem-list-recipients (reclist &optional lst)
  (if (null reclist)
      lst
      (let ((p 0)
	    (r lst))
	(while p
	  (setq p (string-match "[A-Za-z0-9_.-]+@[A-Za-z0-9_.-]+" reclist p))
	  (if p
	      (let ((e (match-end 0)))
		(setq r (cons (substring reclist p e)
			      r)
		      p e))))
	r)))

;;; Returns the header value for regexp, and sets point to it.
;;; If cut is non-nil, the value is deleted as well.
(defun pem-get-header-val (regexp beg end &optional cut)
  (goto-char beg)
  (let ((p1 (re-search-forward regexp end t)))
    (if p1
	(progn
	  (end-of-line)
	  (let ((p2 (point)))
	    (beginning-of-line 2)
	    (while (or (= 9 (char-after (point)))
		       (= 32 (char-after (point))))
	      (end-of-line)
	      (setq p2 (point))
	      (beginning-of-line 2))
	    (let ((val (buffer-substring p1 p2)))
	      (if cut
		  (delete-region p1 p2))
	      (goto-char p1)
	      val))))))

;;; Returns a buffer containing the next part, or nil if no more.
;;; Point in the current buffer is moved to the end of the part.
(defun pem-get-next-part (boundary endm name)
  (if (re-search-forward boundary endm t)
      (let (p1 p2)
	(beginning-of-line 2)
	(setq p1 (point))
	(if (re-search-forward boundary endm t)
	    (progn
	      (beginning-of-line 0)
	      (setq p2 (point))
	      (let ((tmpbuf (generate-new-buffer name)))
		(copy-to-buffer tmpbuf p1 p2)
		tmpbuf))))))

;;; Fix MIME encode message for signing, starting at p.
;;; If encode-from is non-nil, QP encode "From" at
;;; beginning of lines too.
(defun pem-canonicalization (p &optional encode-from)
  ;; LF -> CRLF
  (goto-char p)
  (replace-string "\n" "\r\n")
  (cond (encode-from
	 ;; Some MTAs convert "^From" into "^>From",
	 ;; which would invalidate the signature.
	 (goto-char p)
	 (replace-regexp "^From" "=46rom"))))

;;;
;;; This was nicked from ange-ftp.el
;;;
(defun pem-read-passphrase (prompt &optional default)
  "Read a passphrase, echoing `.' for each character typed.
End with RET, LFD, or ESC.  DEL or C-h rubs out.  C-u kills line.
Optional DEFAULT is passphrase to start with."
  (let ((pass nil)
	(c 0)
	(echo-keystrokes 0)
	(cursor-in-echo-area t))
    (while
	(progn (message "%s%s"
			prompt
			(make-string (length pass) ?.))
	       (setq c (read-char))
	       (and (/= c ?\r) (/= c ?\n) (/= c ?\e)))
      (if (= c ?\C-u)
	  (setq pass "")
	  (if (and (/= c ?\b) (/= c ?\177))
	      (setq pass (concat pass (char-to-string c)))
	      (if (> (length pass) 0)
		  (setq pass (substring pass 0 -1))))))
    (message "")
    (message nil)
    (or pass default "")))


;;;
;;; Get a list of the VM buffer names
;;; The first item is always the primary buffer.
;;;
(defun pem-vm-buffer-name-list ()
  (let* ((file (expand-file-name vm-primary-inbox vm-folder-directory))
	 (buffer (vm-get-file-buffer file)))
    (if (null buffer)
	nil
	(let ((bname (buffer-name buffer)))
	  (list bname
		(concat bname " Summary")
		(concat bname " Presentation"))))))

;;;
;;; Generate a multipart boundary.
;;; This is from vm-mime.el, minus the (random t) call.
;;; We can't use the same function since the random init. is
;;; likely to reset the generator to the same state on a fast
;;; machine and we end up with an identical boundary again.
;;;
(defun pem-mime-make-multipart-boundary ()
  (let ((boundary (make-string 10 ?a))
	(i 0))
    (while (< i (length boundary))
      (aset boundary i (aref vm-mime-base64-alphabet
			     (% (vm-abs (lsh (random) -8))
				(length vm-mime-base64-alphabet))))
      (vm-increment i))
    boundary ))


;;; ------------------------------------------------------------------
;;; PGP callers
;;;

;;; Call the PGP program and sign the current buffer between start and end.
(defun pgp-sign-call (start end)
  (let ((res nil)
	(ok nil))
    (while (not ok)
      (let ((pp (pem-read-passphrase "Passphrase: ")))
	(cond ((zerop (call-process-region start end
					   pgp-program
					   nil '(t nil) nil
					   "+batchmode" "+force" "-fsab"
					   "-z" pp))
	       (setq ok t res t))
	      ((not (y-or-n-p "Signing failed. Try again? "))
	       (setq ok t res nil)))))
    res))

;;; Call the PGP program and verify the signature for file.
(defun pgp-verify-call (file signature)
  (let ((verbuf (generate-new-buffer "*pgp-verify-signature*")))
    (call-process pgp-program signature (list verbuf t) t
		  "+batchmode" "+force" "-f" file)
    (save-excursion
      (set-buffer verbuf)
      (goto-char (point-min))
      ;; Don't confuse users with irrelevant stuff
      (flush-lines "^File .+ has signature.*$")
      (flush-lines "^Text is assumed to be in.*$")
      (toggle-read-only 1)
      (goto-char (point-max)))
    verbuf))

;;; Call the PGP program and encrypt the current buffer between start and end
;;; with the public key of id. The encrypted part is deleted.
(defun pgp-encrypt-call (id start end)
  (zerop (call-process-region start end
			      pgp-program
			      t '(t nil) nil
			      "+batchmode" "+force" "-fea" id)))

;;; Call the PGP program and both sign and encrypt the current buffer
;;; between start and end.
(defun pgp-sign-encrypt-call (id start end)
  (let ((res nil)
	(ok nil))
    (while (not ok)
      (let ((pp (pem-read-passphrase "Passphrase: ")))
	(cond ((zerop (call-process-region start end
					   pgp-program
					   t '(t nil) nil
					   "+batchmode" "+force" "-fesa"
					   "-z" pp id))
	       (setq ok t res t))
	      ((not (y-or-n-p "Signing/encryption failed. Try again? "))
	       (setq ok t res nil)))))
    res))

;;; Call the PGP program and decrypt the current buffer between start and end.
;;; If it was just encrypted, a buffer with the decrypted message is returned.
;;; If it was both signed and encrypted, a list of two buffers is returned,
;;; the decrypted message first, and the signature verification second.
(defun pgp-decrypt-call (start end)
  (let ((decbuf (generate-new-buffer "*pgp-decrypted-message*"))
	(sigbuf (generate-new-buffer "*pgp-decryption-info*"))
	(stderr (make-unique-tmp-file ".decrypt-stderr-"))
	(res nil)
	(ok nil))
    (while (not ok)
      (let* ((pp (pem-read-passphrase "Passphrase: "))
	     (x (call-process-region start end
				     pgp-program
				     nil (list decbuf stderr) nil
				     "+batchmode" "+force" "-f"
				     "-z" pp)))
	(cond ((or (zerop x) (= 1 x))
	       ;(message "Decrypt returned %d" x)
	       (setq ok t res t)
	       (save-excursion
		 (if (file-exists-p stderr)
		     (progn
		       (set-buffer sigbuf)
		       (insert-file stderr)
		       (delete-file stderr)
		       ;; Don't confuse users with irrelevant stuff
		       (flush-lines "^File is encrypted..*$")
		       (flush-lines "^Key can sign..*$")
		       (toggle-read-only 1)))
		 (set-buffer decbuf)
		 (toggle-read-only 1)
		 (goto-char (point-max))))
	      ((not (y-or-n-p "Decryption failed. Try again? "))
	       (setq ok t res nil)))))
    (cond (res
	   (save-excursion
	     ;; Only return sigbuf if it contains something
	     (set-buffer sigbuf)
	     (cond ((zerop (buffer-size))
		    (kill-buffer sigbuf)
		    decbuf)
		   (t (list decbuf sigbuf)))))
	  (t (kill-buffer decbuf)
	     (kill-buffer sigbuf)
	     nil))))

;;; ------------------------------------------------------------------
;;; GPG callers
;;;

(defmacro pem-proc-still-running (p)
  `(and ,p (eq 'run (process-status ,p))))

(defmacro pem-proc-exit-ok (p)
  `(and ,p (eq 'exit (process-status ,p)) (zerop (process-exit-status ,p))))

(defun gpg-call-process (what start end replace &rest args)
  (let ((res nil)
	(ok nil)
	(pbuf "*gpg*"))
    (if (get-buffer pbuf)
	(kill-buffer pbuf))
    (while (not ok)
      ;; gpg doesn't have an option for giving the passphrase on the
      ;; command line, which makes this a magnitude more complicated
      ;; than it should be. >:-(
      (let ((pp (concat (pem-read-passphrase "Passphrase: ") "\n"))
	    (p (let ((process-connection-type nil)) ;Use a pipe
		 (apply 'start-process (append (list "gpg" pbuf	gpg-program)
					       args)))))
	(cond ((pem-proc-still-running p)
	       (set-process-coding-system p 'no-conversion 'no-conversion)
	       (process-send-string p pp)
	       (cond ((pem-proc-still-running p)
		      (process-send-region p start end)
		      (process-send-eof p)
		      ;; Wait for the process to finish...
		      ;; (Why isn't there a proper process wait?)
		      (let ((cnt 10))
			(while (and (> cnt 0) (pem-proc-still-running p))
			  (setq cnt (1- cnt))
			  (accept-process-output p 1 0)))
		      (cond ((pem-proc-exit-ok p)
			     (when replace
			       (goto-char start)
			       (delete-region start end))
			     (insert-buffer pbuf)
			     (goto-char (point-max)) ;Skip to end of insertion
			     (setq ok t res t))
			    ((not (y-or-n-p (concat what
						    " failed. Try again? ")))
			     (setq ok t res nil))))
		     ((not (y-or-n-p (concat what " failed. Try again? ")))
		      (setq ok t res nil))))
	      (t (error "Failed to start %s" gpg-program)
		 (setq ok t res nil)))
	(if (process-status p)
	    (delete-process p))
	(if (get-buffer pbuf)
	    (kill-buffer pbuf))))
    res))

;;; Call the GPG program and sign the current buffer between start and end.
(defun gpg-sign-call (start end)
  (gpg-call-process "Signing" start end nil
		    "--detach-sig" "--armor"
		    "--batch" "--no-tty" "--quiet"
		    "--passphrase-fd" "0"))

;;; Call the GPG program and verify the signature for file.
(defun gpg-verify-call (file signature)
  (let ((verbuf (generate-new-buffer "*gpg-verify-signature*")))
    (call-process gpg-program nil (list verbuf t) t
		  "--batch" "--no-tty" "--quiet" "--verify" signature file)
    (save-excursion
      (set-buffer verbuf)
      (goto-char (point-min))
      ;; Don't confuse users with irrelevant stuff
      (flush-lines "^gpg: checking .*$")
      (flush-lines "^gpg: next trustdb .*$")
      (toggle-read-only 1)
      (goto-char (point-max)))
    verbuf))

;;; Call the GPG program and encrypt the current buffer between start and end
;;; with the public key of id. The encrypted part is deleted.
(defun gpg-encrypt-call (id start end)
  (zerop (call-process-region start end
			      gpg-program
			      t '(t nil) nil
			      "--armor" "--batch" "--no-tty" "--quiet"
			      "--encrypt" "--recipient" id)))

;;; Call the GPG program and both sign and encrypt the current buffer
;;; between start and end.
(defun gpg-sign-encrypt-call (id start end)
  (gpg-call-process "Signing/encrypting" start end t
		    "--armor" "--batch" "--no-tty" "--quiet"
		    "--passphrase-fd" "0"
		    "--sign" "--encrypt" "--recipient" id))

;;; Call the GPG program and decrypt the current buffer between start and end.
;;; If it was just encrypted, a buffer with the decrypted message is returned.
;;; If it was both signed and encrypted, a list of two buffers is returned,
;;; the decrypted message first, and the signature verification second.
(defun gpg-decrypt-call (start end)
  (let ((decbuf (generate-new-buffer "*gpg-decrypted-message*"))
	(sigbuf (generate-new-buffer "*gpg-decryption-info*"))
	(stderr (make-unique-tmp-file ".decrypt-stderr-"))
	(res nil)
	(ok nil))
    (while (not ok)
      (let* ((pp (concat (pem-read-passphrase "Passphrase: ") "\n"))
	     (p (let ((process-connection-type nil) ;Use a pipe
		      (shell-file-name "/bin/sh"))
		  (start-process-shell-command "gpg" decbuf
					       gpg-program
					       "--batch" "--no-tty" "--quiet"
					       "--passphrase-fd" "0"
					       "--decrypt" "2>" stderr))))
	(cond ((pem-proc-still-running p)
	       (set-process-coding-system p 'no-conversion 'no-conversion)
	       (process-send-string p pp)
	       (cond ((pem-proc-still-running p)
		      (process-send-region p start end)
		      (process-send-eof p)
		      ;; Wait for the process to finish...
		      ;; (Why isn't there a proper process wait?)
		      (let ((cnt 10))
			(while (and (> cnt 0) (pem-proc-still-running p))
			  (setq cnt (1- cnt))
			  (accept-process-output p 1 0)))
		      (cond ((pem-proc-exit-ok p)
			     (save-excursion
			       (when (file-exists-p stderr)
				 (set-buffer sigbuf)
				 (insert-file stderr)
				 (delete-file stderr)
				 (toggle-read-only 1))
			       (set-buffer decbuf)
			       (toggle-read-only 1))
			     (setq ok t res t))
			    ((not (y-or-n-p "Decryption failed. Try again? "))
			     (setq ok t res nil))))
		     ((not (y-or-n-p "Decryption failed. Try again? "))
		      (setq ok t res nil))))
	      (t (error "Failed to start %s" gpg-program)
		 (setq ok t res nil)))
	(when (process-status p)
	  (delete-process p))))
    (cond (res
	   (save-excursion
	     ;; Get rid of that annoying "kill" message,
	     ;; at the last line only
	     (set-buffer decbuf)
	     (goto-char (point-max))
	     (beginning-of-line -1)
	     (toggle-read-only 0)
	     (flush-lines "^Process gpg kill.*$")
	     (toggle-read-only 1)
	     ;; Only return sigbuf if it contains something
	     (set-buffer sigbuf)
	     (cond ((zerop (buffer-size))
		    (kill-buffer sigbuf)
		    decbuf)
		   (t (list decbuf sigbuf)))))
	  (t (kill-buffer decbuf)
	     (kill-buffer sigbuf)
	     nil))))

;;; ------------------------------------------------------------------
;;; Utility functions.
;;;
;;; These are not used anywhere above, but might be handy sometimes.
;;; Some people send GnuPG clear text signatures in emails for instance.
;;;

;;; In VM, attempt to verify an PGP clear text signature.
(defun gpg-vm-verify-cleartext ()
"Verify the clear text signature, if any, of the current VM message,
using Gnu PG. The program to call is set in the variable gpg-program."
  (interactive)
  (let ((case-fold-search nil)
	(vmbuffers (pem-vm-buffer-name-list)))
    (if (not (member (buffer-name) vmbuffers))
	(error "Current buffer is not a mail buffer")
	(save-excursion
	  (set-buffer (car vmbuffers))
	  (widen)
	  (let ((begm (re-search-backward "^From " (point-min) t)))
	    (if (null begm)
		(error "Message beginning not found")
		(progn
		  (beginning-of-line 2) (setq begm (point))
		  (let ((endm (or
				(re-search-forward "^From " (point-max) t)
				(point-max))))
		    (goto-char begm)
		    (let ((midm (search-forward "\n\n" endm t)))
		      (gpg-verify-cleartext (point) begm endm))))))))))

;;; Attempt to locate a clear text signature following point, and verify it.
(defun gpg-verify-cleartext (point &optional min max)
"Try to locate a Gnu PG clear text signature, starting at POINT. It searches
forward first, and then backwards. If MIN and MAX are given, they set the
boundaries of how far to search.
The program to call is set in the variable gpg-program."
  (interactive "d")
  (save-excursion
    (goto-char point)
    (let ((begin (or (search-forward "-----BEGIN PGP SIGNED MESSAGE-----"
				     (or max (point-max)) t)
		     (search-backward "-----BEGIN PGP SIGNED MESSAGE-----"
				      (or min (point-min)) t))))
      (cond (begin
	     (beginning-of-line 1)
	     (setq begin (point))
	     (let ((end (search-forward "-----END PGP SIGNATURE-----"
					(point-max) t)))
	       (cond (end
		      (beginning-of-line 2)
		      (gpg-verify-region begin (point)))
		     (t (error "No end of PGP signature found")))))
	    (t (error "No beginning of PGP signed message found"))))))
  
;;; Verify a (assumed) clear text signature in the given region.
(defun gpg-verify-region (begin end)
  (let* ((file (make-unique-tmp-file ".pgp-temp-"))
	 (buf (generate-new-buffer file)))
    (unwind-protect
	 (progn
	   (copy-to-buffer buf begin end)
	   (set-buffer buf)
	   (write-file file)
	   (set-file-modes file 384)	; -rw-------
	   (message nil)
	   (let ((verbuf (generate-new-buffer "*gpg-verify-signature*")))
	     (call-process gpg-program nil (list verbuf t) t
			   "--batch" "--no-tty" "--quiet" "--verify" file)
	     (save-excursion
	       (set-buffer verbuf)
	       (goto-char (point-min))
	       ;; Don't confuse users with irrelevant stuff
	       (flush-lines "^gpg: checking .*$")
	       (flush-lines "^gpg: next trustdb .*$")
	       (toggle-read-only 1)
	       (goto-char (point-max))
	       (display-buffer verbuf))))
      (if buf
	  (kill-buffer buf))
      (if (file-exists-p file)
	  (delete-file file)))))

;;; ------------------------------------------------------------------
(provide 'pgp)