;;; -*- MODE: Lisp; PACKAGE: EDITOR; -*-
;;;
;;; gnupg.l -- simple GnuPG gpg command front-end foy xyzzy
;;;
;;;
;;; 動作にはGnuPGパッケージが必要です
;;; GnuPGについては
;;;
;;;   The GNU Privacy Guard - GnuPG.org <http://www.gnupg.org/>
;;;
;;; を参照してください
;;;
;;; 動作を確認したGnuPGパッケージのバージョンは 1.4.3 です
;;;
;;;
;;; キーバインドの定義箇所はファイル最後尾にあります。
;;;
;;; MODE          COMMANDKEY  DESCRIPTION
;;; *summary-map* v - d       メッセージを復号化
;;; *draft-map*   v - e       メッセージを暗号化し署名
;;; *draft-map*   v - c       メッセージに署名(クリア署名)
;;;
;;;
;;;
;;; site-lisp/kamail3/以下にこのファイルを配置した後に
;;; ~/.kamail3/config.l に以下を記述してください。
;;;
;;; (require "kamail3/gnupg")
;;; (setq *gnupg-gpg-command* "X:/path/to/GNU/GnuPG/gpg.exe")
;;;


(eval-when (:compile-toplevel :load-toplevel :execute)
  (require "kamail3/defs"))

(provide "kamail3/gnupg")

(in-package "kamail3")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; user variables
;;;
(defvar *gnupg-gpg-command* "C:/Program Files/GNU/GnuPG/gpg.exe"
  "GnuPG gpg コマンドのパスを記述してください。")

(defvar *gnupg-buffer-process* " *GnuPG Process* "
  "GnuPG process using buffer.")

(defvar *gnupg-hide-input-passphrase* t
  "パスフレーズを入力する際、マスクするかどうか")

(defvar *gnupg-local-user* nil
  "デフォルトユーザー以外のユーザー名を利用する場合は指定する")

(defvar *gnupg-remember-passwords-minutes* 1
  "パスワードを記憶しておく時間(分)")

(defvar *gnupg-print-gpg-error* t
  "gpg コマンドが失敗したときに出力されたエラーを表示するかどうか")

(defvar *gnupg-auto-decrypt-message* nil
  "暗号化されたメッセージを自動的に復号化するかどうか")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defconstant *gnupg-begin-pgp-message* "-----BEGIN PGP MESSAGE-----")
(defconstant *gnupg-end-pgp-message* "-----END PGP MESSAGE-----")
(defconstant *gnupg-begin-signed-message* "-----BEGIN PGP SIGNED MESSAGE-----")
(defconstant *gnupg-begin-pgp-signature* "-----BEGIN PGP SIGNATURE-----")
(defconstant *gnupg-end-pgp-signature* "-----END PGP SIGNATURE-----")

(defconstant *gnupg-pgp-pair-messages*
  (list (cons *gnupg-begin-pgp-message* *gnupg-end-pgp-message*)
		(cons *gnupg-begin-signed-message* *gnupg-end-pgp-signature*)
		(cons *gnupg-begin-pgp-signature* *gnupg-end-pgp-signature*)))

(defconstant *gnupg-gpg-result-line* "\n---== GnuPG Command Results ==---\n")
(defconstant *gnupg-gpg-comment*
  (format nil "Using GnuPG with ~a/~a (gnupg.l)"
		  *prog-name* *prog-version*))
(setq gnupg-remember-passwords nil)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; function 
;;;
(defun gnupg-exist-command ()
  (if *gnupg-gpg-command*
	  (file-exist-p *gnupg-gpg-command*)
	nil))

(defun gnupg-make-process (option exec-dir)
  (let ((proc nil))
	(when (gnupg-exist-command)
	  (setq proc (make-process (concat *gnupg-gpg-command* " " option)
							   :exec-directory exec-dir
							   :output (get-buffer-create *gnupg-buffer-process*))))
	proc))

(defun gnupg-get-pgp-pattern ()
  (if (gnupg-exist-message-buffer)
	  (progn
		(save-excursion
		  (set-buffer *buffer-message*)
		  (goto-char (point-min))
		  (let (item result buf)
			(setq item
				  (dolist (pattern (list *gnupg-begin-pgp-message*
										 *gnupg-begin-signed-message*
										 *gnupg-begin-pgp-signature*)
								   buf)
					(if (scan-buffer pattern )
						(unless buf
						  (setq buf pattern))
					  nil)))
			(setq result
				  (assoc item
						 *gnupg-pgp-pair-messages*
						 :test 'equal))
			result)))
	nil))

(defun gnupg-exist-pgp-pattern ()
  (if (gnupg-exist-message-buffer)
	  (progn
		(save-excursion
		  (set-buffer *buffer-message*)
		  (goto-char (point-min))
		  (if (scan-buffer *gnupg-begin-pgp-message*)
			  t
			nil)))
	nil))

(defun gnupg-exist-message-buffer ()
  ""
  (find-buffer *buffer-message*))

(defun gnupg-scan-message-body (&optional patternlist)
  ""
  (let (from to)
	(save-excursion
	  (goto-char (point-min))
	  (unless (junk::mail-goto-body-beg)
		(return-from gnupg-scan-message-body))
	  (setq from (if (scan-buffer (car patternlist) :no-dup nil :tail nil :regexp nil)
					 (point)
				   nil))
	  (setq to (if (scan-buffer (cdr patternlist) :no-dup t :tail t :regexp nil)
				   (point)
				 nil))
	  (values from to)
	  )))

(defun gnupg-get-message-body-as-file (&optional patternlist)
  "メール本文の内容を保存したファイル名を返します。"
  (if (gnupg-exist-message-buffer)
      (save-excursion
        (set-buffer *buffer-message*)
        (multiple-value-bind (from to)
            (gnupg-scan-message-body patternlist)
          (when (and from to)
            (gnupg-save-message-as-file 
               (buffer-substring from to)))))
    nil))

(defun gnupg-write-message-as-file (file msg)
  ""
  (with-open-file (fp file
                      :direction :output
                      :if-exist-file :overrite
                      :if-not-exist-file :create)
    (princ msg fp)))

(defun gnupg-save-message-as-file (msg)
  ""
  (let ((filespec (make-temp-file-name "gnupg-")))
    (ignore-errors
       (gnupg-write-message-as-file filespec msg))
    filespec))

(defun gnupg-get-passphrase ()
  (interactive)
  (when (and *gnupg-remember-passwords-minutes*
			 gnupg-remember-passwords)
	(return-from gnupg-get-passphrase gnupg-remember-passwords))
  (if *gnupg-hide-input-passphrase*
	  ;;; xyzzy Reference より
	  (let ((ans ""))
		(loop
		  (minibuffer-prompt
			 "GnuPG passphrase: ~a"
			 (if (< 0 (length ans))
				 (make-sequence 'string (length ans) :initial-element #\*)
			   ""))
		  (let ((c (read-char *keyboard*)))
			(case c
			  (#\RET (return ans))
			  (#\C-h (when (< 0 (length ans))
					   (setq ans (substring ans 0 (1- (length ans))))))
			  (#\C-g (quit))
			  (t (setq ans (format nil "~a~c" ans c))))))
		)
	(read-string "GnuPG passphrase: " :default "passphrase")))

(defun gnupg-insert-gpg-result ()
  (let ((cur_pos (point)) buf)
	(save-window-excursion 
	  (set-buffer *gnupg-buffer-process*)
	  (setq buf (buffer-substring 0 (point-max)))
	  (delete-region 0 (point-max)))
	(setq buf (map-internal-to-jis buf))
	(insert *gnupg-gpg-result-line*)
	(insert buf)
	))

(defun gnupg-replace-message-buffer (file &optional patternlist)
  (let (structure charset)
	(save-window-excursion
	(set-buffer *buffer-source*)
	(multiple-value-bind (from to)
		(gnupg-scan-message-body patternlist)
	  (when (and from to)
		(set-buffer *buffer-source*)
		(goto-char (point-min))
		(setq structure (junk::mail-parse))
		(setq charset
			  (junk::mail-get-content-charset
				 (junk::mail-get-header-content 
					"content-type"
					(junk::mailstructure-headers structure))))
		(delete-region from to)
		(with-open-file (fp file :direction :input)
		  (let (buf buffer)
			(setq buffer
				  (with-output-to-string (out)
					(while (setq buf (read-line fp nil nil nil))
					  (princ buf out) (princ "\n" out))))
			(insert buffer)
			(gnupg-insert-gpg-result)))
		(goto-char (point-min))
		(setq structure (junk::mail-parse))
		(goto-char (point-min))
		(junk::modify-read-only-buffer
		   (set-buffer *buffer-message*)
		   (delete-region 0 (point-max))
		   (message-print structure)))
	  t))))

(defun gnupg-replace-draft-buffer (file)
  (let (structure)
	(save-window-excursion
	  (junk::modify-read-only-buffer
		 (goto-char (draft-body-start-point))
		 (delete-region (point) (point-max))
		 (with-open-file (fp file :direction :input)
		   (let (buf buffer)
			 (setq buffer
				   (with-output-to-string (out)
					 (while (setq buf (read-line fp nil nil nil))
					   (princ buf out) (princ "\n" out))))
             (setf (draft-body *draft-current*) buffer)
             (insert buffer)))))
    t))

(defun gnupg-reset-remember-passwords ()
  (setq gnupg-remember-passwords nil))

(defun gnupg-get-recipients ()
  (let (recipient recipients)
    (dolist (fields (list "to" "cc" "bcc") recipients)
      (setq recipient (junk::mail-get-header-value
                         fields (draft-header *draft-current*)))
      (setq recipients
            (append recipients
                    (if (listp recipient) recipient
                      (list recipient)))))
    recipients))

(defun gnupg-parse-gpg-result (outputfile)
  (if (file-exist-p outputfile)
	  t
	(if *gnupg-print-gpg-error*
		(progn
		  (let (buf)
			(save-excursion
			  (set-buffer *gnupg-buffer-process*)
			  (setq buf (map-internal-to-sjis
						   (buffer-substring (point-min) (point-max))))
			  (junk::modify-read-only-buffer
				 (set-buffer *buffer-draft*)
				 (goto-char (point-max))
				 (insert *gnupg-gpg-result-line*)
				 (insert buf))
			  ))
		  nil)
	  nil)))

(defun gnupg-decrypt-message ()
  (interactive)
  (let ((pass nil)
		(filename nil)
		(proc nil)
		(option nil)
		(outputfile nil)
		(patternlist nil)
		)
	(unless (setq patternlist (gnupg-get-pgp-pattern))
	  (return-from gnupg-decrypt-message nil))
	(setq pass (gnupg-get-passphrase))
	(setq filename (gnupg-get-message-body-as-file patternlist))
	(save-window-excursion
	  (if (and pass filename)
		  (progn
			(setq outputfile (format nil "~a.decrypt" filename))
			(setq option (concat (when *gnupg-local-user*
								   (format nil "-u ~a " *gnupg-local-user*))
								 "--passphrase-fd 0 -o " outputfile
								 " -d " filename))
			(setq proc (gnupg-make-process option (directory-namestring filename)))
			(process-send-string proc (concat pass "\n"))
			(loop
			  (if (equal :exit (process-status proc))
				  (return t)
				(sleep-for 0.0001)))
			(unless (gnupg-parse-gpg-result outputfile)
			  ; invalid passwords, or failed gpg command.
			  (message "Failed decrypt process.")
			  (delete-file filename)
			  (delete-buffer *gnupg-buffer-process*)
			  (return-from gnupg-decrypt-message nil))
			(when (and *gnupg-remember-passwords-minutes*
					   (not gnupg-remember-passwords))
			  (start-timer (* 60 *gnupg-remember-passwords-minutes*)
						   'gnupg-reset-remember-passwords t)
			  (setq gnupg-remember-passwords pass))
			(gnupg-replace-message-buffer outputfile patternlist)
			(delete-file filename
						 :if-access-denied :skip
						 :if-does-not-exist :skip)
			(delete-file outputfile
						 :if-access-denied :skip
						 :if-does-not-exist :skip)
			)
		(message "~a" "Failed decrypt process.")))))

(defun gnupg-encrypt-message ()
  (interactive)
  (let ((pass nil)
		(filename nil)
		(proc nil)
		(option nil)
		(outputfile nil)
		(recipients nil))
	(when *buffer-draft*
	  (save-excursion
		(set-buffer *buffer-draft*)
		(setq filename
			  (gnupg-save-message-as-file
				 (map-internal-to-jis
					(buffer-substring (draft-body-start-point) (point-max)))))
		(setq pass (gnupg-get-passphrase))
		(if (and filename pass)
			(progn
              (setq recipients (gnupg-get-recipients))
			  (setq outputfile (format nil "~a.encrypt.asc" filename))
			  (setq option (concat (when *gnupg-local-user*
									 (format nil "-u ~a " *gnupg-local-user*))
								   (format nil " ~{-r ~a ~}"
                                    (if (listp recipients)
                                        recipients
                                      (list recipients)))
								   " --comment \"" *gnupg-gpg-comment* "\""
								   " --passphrase-fd 0 -o \"" outputfile "\""
								   " -eas \"" filename "\""))
			  (setq proc (gnupg-make-process option (directory-namestring filename)))
			  (process-send-string proc (concat pass "\n"))
			  (loop
				(if (equal :exit (process-status proc))
					(return t)
				  (sleep-for 0.0001)))
			  (unless (gnupg-parse-gpg-result outputfile)
				; invalid passwords, or failed gpg command.
				(message "Failed encrypt process.")
				(delete-file filename)
				(delete-buffer *gnupg-buffer-process*)
				(return-from gnupg-encrypt-message nil))
			  (when (and *gnupg-remember-passwords-minutes*
						 (not gnupg-remember-passwords))
				(start-timer (* 60 *gnupg-remember-passwords-minutes*)
							 'gnupg-reset-remember-passwords t)
				(setq gnupg-remember-passwords pass))
			  (gnupg-replace-draft-buffer outputfile)
              (delete-file filename
						   :if-access-denied :skip
						   :if-does-not-exist :skip)
			  (delete-file outputfile
						   :if-access-denied :skip
						   :if-does-not-exist :skip)
			  )
		  (message "Failed encrypt process."))
		))))


(defun gnupg-clearsign-message ()
  (interactive)
  (let ((pass nil) (filename nil)
        (proc nil) (option nil)
        (outputfile nil) (recipients nil))
    (when *buffer-draft*
      (save-excursion
        (set-buffer *buffer-draft*)
        (setq filename
              (gnupg-save-message-as-file
                 (buffer-substring (draft-body-start-point) (point-max))))
        (setq pass (gnupg-get-passphrase))
        (if (and filename pass)
            (progn
              (setq recipients (gnupg-get-recipients))
              (setq outputfile (format nil "~a.clearsign.asc" filename))
              (setq option
                    (concat (when *gnupg-local-user*
                                     (format nil "-u ~a " *gnupg-local-user*))
                            (format nil " ~{-r ~a ~}"
                                    (if (listp recipients)
                                        recipients
                                      (list recipients)))
							" --comment \"" *gnupg-gpg-comment* "\"" 
							" --passphrase-fd 0 -o \"" outputfile "\""
							" --clearsign \"" filename "\""))
              (setq proc (gnupg-make-process option (directory-namestring filename)))
              (process-send-string proc (concat pass "\n"))
              (when (and *gnupg-remember-passwords-minutes*
                         (not gnupg-remember-passwords))
                (start-timer (* 60 *gnupg-remember-passwords-minutes*)
                             'gnupg-reset-remember-passwords t)
                (setq gnupg-remember-passwords pass))
              (loop
                (if (equal :exit (process-status proc))
                    (return t)
                  (sleep-for 0.0001)))
              (gnupg-replace-draft-buffer outputfile)
              (delete-file filename
						   :if-access-denied :skip
						   :if-does-not-exist :skip)
			  (delete-file outputfile
						   :if-access-denied :skip
						   :if-does-not-exist :skip)
              )
          (message "Failed clearsign process."))))))

(if *gnupg-auto-decrypt-message*
    ; override message-show function.
	(progn
	  (defun message-show (file)
		(message-window-set)
		(setq *message-file-current* file)
		(let (structure)
		  (source-buffer-set)
		  (erase-buffer (selected-buffer))
		  (insert-file-noconv file)
		  (setq structure (junk::mail-parse))
		  (message-buffer-set)
		  (message-mode)
		  (setq *message-structure* structure)
		  (junk::modify-read-only-buffer
			 (erase-buffer (selected-buffer))
			 (message-print structure)
			 (goto-char (point-min))
			 (gnupg-decrypt-message))
          t)))
	  )


(when *gnupg-remember-passwords-minutes*
  (add-hook
	 '*kamail3-finish-hook*
	 '(lambda () (setq gnupg-remember-passwords nil))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; key bindings
(define-key *summary-map* '(#\v #\d) 'gnupg-decrypt-message)
(define-key *draft-map* '(#\v #\e) 'gnupg-encrypt-message)
(define-key *draft-map* '(#\v #\c) 'gnupg-clearsign-message)