(require 'epg)
(require 'font-lock)

(defgroup epa nil
  "EasyPG Assistant, GUI for EasyPG."
  :group 'epg)

(defgroup epa-faces nil
  "Faces for epa-mode."
  :group 'epa)

(defvar epa-buffer nil)

(defface epa-trust-full-face
  '((((class color) (background dark))
     (:foreground "PaleTurquoise" :bold t))
    (t
     (:bold t)))
  "Face used for displaying the trust-full addon."
  :group 'epa-faces)
(defvar epa-trust-full-face 'epa-trust-full-face)

(defface epa-trust-disabled-face
  '((((class color) (background dark))
     (:foreground "PaleTurquoise" :italic t))
    (t
     ()))
  "Face used for displaying the disabled trust."
  :group 'epa-faces)
(defvar epa-trust-disabled-face 'epa-trust-disabled-face)

(defface epa-trust-unknown-face
  '((t
     (:italic t)))
  "Face used for displaying the trust-unknown addon."
  :group 'epa-faces)
(defvar epa-trust-unknown-face 'epa-trust-unknown-face)

(defface epa-trust-marginal-face
  '((t
     (:italic t :inverse-video t)))
  "Face used for displaying the trust-marginal addon."
  :group 'epa-faces)
(defvar epa-trust-marginal-face 'epa-trust-marginal-face)

(defface epa-user-id-face
  '((((class color)
      (background dark))
     (:foreground "lightyellow"))
    (((class color)
      (background light))
     (:foreground "blue4"))
    (t
     ()))
  "Face used for displaying the user-id addon."
  :group 'epa-faces)
(defvar epa-user-id-face 'epa-user-id-face)

(defcustom epa-validity-face-alist
  '((?o . epa-trust-unknown-face)
    (?i . epa-trust-disabled-face)
    (?d . epa-trust-disabled-face)
    (?r . epa-trust-disabled-face)
    (?e . epa-trust-disabled-face)
    (?- . epa-trust-unknown-face)
    (?q . epa-trust-unknown-face)
    (?n . epa-trust-disabled-face)
    (?m . epa-trust-marginal-face)
    (?f . epa-trust-full-face)
    (?u . epa-trust-full-face)
    (?  . epa-trust-full-face))
  "An alist mapping marks on epa-buffer to faces."
  :type 'list
  :group 'epa)

(defcustom epa-font-lock-keywords
  '(("^[* ]\\([-oidreqnmfu ]\\)\\s-+\\(\\S-+\\)\\s-+\\(.*\\)"
     (2 (cdr (assq (aref (match-string 1) 0)
		   epa-validity-face-alist)))
     (3 epa-user-id-face)))
  "Default expressions to addon in epa-mode."
  :type '(repeat (list string))
  :group 'epa)

(defvar epa-mode-map
  (let ((keymap (make-sparse-keymap)))
    (define-key keymap "m" 'epa-command-mark-key)
    (define-key keymap "u" 'epa-command-unmark-key)
    (define-key keymap "n" 'epa-command-next-line)
    (define-key keymap "p" 'previous-line)
    (define-key keymap "e" 'epa-command-encrypt-file)
    (define-key keymap "s" 'epa-command-sign-file)
    (define-key keymap " " 'scroll-up)
    (define-key keymap [delete] 'scroll-down)
    (define-key keymap "q" 'bury-buffer)
    keymap))

(defun epa-mode ()
  "Major mode for displaying addon list.
All normal editing commands are turned off."
  (kill-all-local-variables)
  (buffer-disable-undo)
  (setq major-mode 'epa-mode
	mode-name "EPA"
	truncate-lines t
	buffer-read-only t)
  (use-local-map epa-mode-map)
  (make-local-variable 'font-lock-defaults)
  (setq font-lock-defaults '(epa-font-lock-keywords t))
  ;; In XEmacs, auto-initialization of font-lock is not effective
  ;; if buffer-file-name is not set.
  (font-lock-set-defaults)
  (make-local-variable 'epa-marked-keys)
  (run-hooks 'epa-mode-hook))

(defun epa ()
  (interactive)
  (unless epa-buffer
    (setq epa-buffer (generate-new-buffer "*EPA*")))
  (set-buffer epa-buffer)
  (epa-mode)
  (let ((inhibit-read-only t)
	buffer-read-only
	configuration pointer entry point)
    (erase-buffer)
    (insert "EasyPG Assistant\n\n")
    (setq configuration (epg-configuration))
    (if (setq entry (assq 'version configuration))
	(insert (format "GnuPG %s\n" (cdr entry))))
    (if (setq entry (assq 'pubkey configuration))
	(insert (format "Pubkey: %s\n"
			(mapconcat
			 (lambda (algorithm)
			   (if (setq entry
				     (assq algorithm
					   epg-pubkey-algorithm-alist))
			       (cdr entry)
			     (format "(unknown: %d)" algorithm)))
			 (cdr entry) ", "))))
    (if (setq entry (assq 'cipher configuration))
	(insert (format "Cipher: %s\n"
			(mapconcat
			 (lambda (algorithm)
			   (if (setq entry
				     (assq algorithm
					   epg-cipher-algorithm-alist))
			       (cdr entry)
			     (format "(unknown: %d)" algorithm)))
			 (cdr entry) ", "))))
    (if (setq entry (assq 'digest configuration))
	(insert (format "Hash: %s\n"
			(mapconcat
			 (lambda (algorithm)
			   (if (setq entry
				     (assq algorithm
					   epg-digest-algorithm-alist))
			       (cdr entry)
			     (format "(unknown: %d)" algorithm)))
			 (cdr entry) ", "))))
    (if (setq entry (assq 'compress configuration))
	(insert (format "Compression: %s\n"
			(mapconcat
			 (lambda (algorithm)
			   (if (setq entry
				     (assq algorithm
					   epg-compress-algorithm-alist))
			       (cdr entry)
			     (format "(unknown: %d)" algorithm)))
			 (cdr entry) ", "))))
    (insert "\nSecret keys:\n\n")
    (setq pointer (epg-list-keys nil t))
    (while pointer
      (setq point (point))
      (setq entry (cdr (assq 'sec (car pointer))))
      (setq key-id (cdr (assq 'key-id entry)))
      (insert (format "   %s %s\n"
		      key-id
		      (cdr (assq 'user-id (assq 'uid (car pointer))))))
      (put-text-property point (point) 'epa-key-id key-id)
      (put-text-property point (point) 'epa-key-secret t)
      (setq pointer (cdr pointer)))
    (insert "\nPublic keys:\n\n")
    (setq pointer (epg-list-keys nil))
    (while pointer
      (setq point (point))
      (setq entry (cdr (assq 'pub (car pointer))))
      (setq key-id (cdr (assq 'key-id entry)))
      (insert (format " %s %s %s\n"
		      (or (cdr (assq 'trust entry)) ? )
		      key-id
		      (cdr (assq 'user-id (assq 'uid (car pointer))))))
      (put-text-property point (point) 'epa-key-id key-id)
      (setq pointer (cdr pointer)))
    (goto-char (point-min))
    (pop-to-buffer (current-buffer))
    (delete-other-windows)))

(defun epa-key-id ()
  (let ((key-id (get-text-property (point) 'epa-key-id))
	point)
    (unless key-id
      (setq point (next-single-property-change (point) 'epa-key-id))
      (when point
	(goto-char point)
	(setq key-id (get-text-property (point) 'epa-key-id))))
    key-id))

(defun epa-command-mark-key (key-id)
  (interactive
   (progn
     (unless (eq major-mode 'epa-mode)
       (error "Not in `epa-mode'"))
     (list (epa-key-id))))
  (let ((point (point))
	(inhibit-read-only t)
	buffer-read-only)
    (while (and point
		(not (equal (get-text-property point 'epa-key-id) key-id)))
      (setq point (next-single-property-change point)))
    (unless point
      (error "Key %s not found" key-id))
    (goto-char point)
    (beginning-of-line)
    (delete-char)
    (setq point (point))
    (insert "*")
    (put-text-property point (point) 'epa-key-id key-id)
    (forward-line)))

(defun epa-command-unmark-key (key-id)
  (interactive
   (progn
     (unless (eq major-mode 'epa-mode)
       (error "Not in `epa-mode'"))
     (list (epa-key-id))))
  (let ((point (point))
	(inhibit-read-only t)
	buffer-read-only)
    (while (and point
		(not (equal (get-text-property point 'epa-key-id) key-id)))
      (setq point (next-single-property-change point)))
    (unless point
      (error "Key %s not found" key-id))
    (goto-char point)
    (beginning-of-line)
    (delete-char)
    (setq point (point))
    (insert " ")
    (put-text-property point (point) 'epa-key-id key-id)
    (forward-line)))

(defun epa-command-next-line (count)
  (interactive "p")
  (if (get-text-property (point) 'epa-key-id)
      (next-line count)
    (let ((point (next-single-property-change (point) 'epa-key-id)))
      (if (and point
	       (get-text-property point 'epa-key-id))
	  (goto-char point)))))

(defun epa-command-encrypt-file (plain cipher recipients sign)
  (interactive
   (save-excursion
     (set-buffer epa-buffer)
     (goto-char (point-min))
     (let (plain recipients)
       (while (re-search-forward "^\\*" nil t)
	 (unless (get-text-property (point) 'epa-key-secret)
	   (setq recipients (cons (get-text-property (point) 'epa-key-id)
				  recipients))))
       (list (setq plain (expand-file-name (read-file-name "Plain file: ")))
	     (expand-file-name
	      (read-file-name (format "Cipher file (default %s.gpg) "
				      (file-name-nondirectory plain))
			      (file-name-directory plain)
			      (concat plain ".gpg")))
	     recipients
	     current-prefix-arg))))
  (message "Encrypting %s..." (file-name-nondirectory plain))
  (epg-encrypt-file (epg-make-context)
		    plain
		    recipients
		    (expand-file-name cipher)
		    sign)
  (message "Encrypting %s...done" (file-name-nondirectory plain)))

(defun epa-command-sign-file (plain signature detached signers)
  (interactive
   (save-excursion
     (set-buffer epa-buffer)
     (goto-char (point-min))
     (let ((extension (if current-prefix-arg ".sig" ".gpg"))
	   plain signers)
       (while (re-search-forward "^\\*" nil t)
	 (if (get-text-property (point) 'epa-key-secret)
	     (setq signers (cons (get-text-property (point) 'epa-key-id)
				 signers))))
       
       (list (setq plain (expand-file-name (read-file-name "Plain file: ")))
	     (expand-file-name
	      (read-file-name (format "Signature file (default %s%s) "
				      (file-name-nondirectory plain)
				      extension)
			      (file-name-directory plain)
			      (concat plain extension)))
	     current-prefix-arg
	     signers))))
  (let ((context (epg-make-context)))
    (epg-context-set-signers context signers)
    (message "Signing %s..." (file-name-nondirectory plain))
    (epg-sign-file context
		   plain
		   signature
		   (if detached 'detached))
    (message "Signing %s...done" (file-name-nondirectory plain))))

(provide 'epa)

;;; epa.el ends here