(defgroup epg ()
  "EasyPG, yet another GnuPG interface.")

(defcustom epg-gpg-program "gpg"
  "The `gpg' executable."
  :group 'epg
  :type 'string)

(defvar epg-user-id nil
  "GnuPG ID of your default identity.")

(defvar epg-user-id-alist nil
  "An alist mapping from key ID to user ID.")

(defvar epg-read-point nil)
(defvar epg-pending-status-list nil)
(defvar epg-key-id nil)
(defvar epg-context nil)
(defvar epg-debug nil)

(defvar epg-colons-pub-spec
  '((trust "[^:]")
    (length "[0-9]+" 0 string-to-number)
    (algorithm "[0-9]+" 0 string-to-number)
    (key-id "[^:]+")
    (creation-date "[0-9]+")
    (expiration-date "[0-9]+")
    nil
    (ownertrust "[^:]")
    nil
    nil
    (capability "[escaESCA]*"))
  "The schema of keylisting output whose type is \"pub\".
This is used by `epg-list-keys'.")

(defvar epg-colons-sec-spec
  '((trust "[^:]")
    (length "[0-9]+" 0 string-to-number)
    (algorithm "[0-9]+" 0 string-to-number)
    (key-id "[^:]+")
    (creation-date "[0-9]+")
    (expiration-date "[0-9]+")
    nil
    (ownertrust "[^:]"))
"The schema of keylisting output whose type is \"sec\".
This is used by `epg-list-keys'.")

(defvar epg-colons-uid-spec
  '((trust "[^:]")
    nil
    nil
    nil
    (creation-date "[0-9]+")
    (expiration-date "[0-9]+")
    (hash "[^:]+")
    nil
    (user-id "[^:]+"))
  "The schema of keylisting output whose type is \"uid\".
This is used by `epg-list-keys'.")
    
(defun epg-make-context (&optional protocol armor textmode include-certs
				   process output-file result)
  "Return a context object."
  (vector protocol armor textmode include-certs
	  (list #'epg-passphrase-callback)
	  (list #'epg-progress-callback)
	  nil process output-file result))

(defun epg-context-protocol (context)
  "Return the protocol used within the context."
  (aref context 0))

(defun epg-context-armor (context)
  "Return t if the output shouled be ASCII armored in the CONTEXT context."
  (aref context 1))

(defun epg-context-textmode (context)
  "Return t if canonical text mode should be used in the CONTEXT context."
  (aref context 2))

(defun epg-context-include-certs (context)
  "Return how many certificates should be included in an S/MIME signed
message."
  (aref context 3))

(defun epg-context-passphrase-callback (context)
  "Return the function used to query passphrase."
  (aref context 4))

(defun epg-context-progress-callback (context)
  "Return the function which handles progress update."
  (aref context 5))

(defun epg-context-signers (context)
  "Return the list of key-id for singning."
  (aref context 6))

(defun epg-context-process (context)
  "Return the process object of `epg-gpg-program'.
This function is for internal use only."
  (aref context 7))

(defun epg-context-output-file (context)
  "Return the output file of `epg-gpg-program'.
This function is for internal use only."
  (aref context 8))

(defun epg-context-result (context name)
  "Return the result of the previous cryptographic operation."
  (cdr (assq name (aref context 9))))

(defun epg-context-set-protocol (context protocol)
  "Set the protocol used within the context."
  (aset context 0 protocol))

(defun epg-context-set-armor (context armor)
  "Specify if the output shouled be ASCII armored in the CONTEXT context."
  (aset context 1 armor))

(defun epg-context-set-textmode (context textmode)
  "Specify if canonical text mode should be used in the CONTEXT context."
  (aset context 2 textmode))

(defun epg-context-set-include-certs (context include-certs)
 "Set how many certificates should be included in an S/MIME signed message."
  (aset context 3 include-certs))

(defun epg-context-set-passphrase-callback (context passphrase-callback
						    &optional handback)
  "Set the function used to query passphrase."
  (aset context 4 (cons passphrase-callback handback)))

(defun epg-context-set-progress-callback (context progress-callback
						  &optional handback)
  "Set the function which handles progress update."
  (aset context 5 (cons progress-callback handback)))

(defun epg-context-set-signers (context signers)
 "Set the list of key-id for singning."
  (aset context 6 signers))

(defun epg-context-set-process (context process)
  "Set the process object of `epg-gpg-program'.
This function is for internal use only."
  (aset context 7 process))

(defun epg-context-set-output-file (context output-file)
  "Set the output file of `epg-gpg-program'.
This function is for internal use only."
  (aset context 8 output-file))

(defun epg-context-set-result (context name result)
  "Set the result of the previous cryptographic operation."
  (let ((entry (assq name (aref context 9))))
    (if entry
	(setcdr entry result)
      (aset context 9 (cons (cons name result) (aref context 9))))))

(defun epg-make-signature (status key-id user-id)
  "Return a signature object."
  (vector status key-id user-id nil))

(defun epg-signature-status (signature)
  "Return the status code of SIGNATURE."
  (aref signature 0))

(defun epg-signature-key-id (signature)
  "Return the key-id of SIGNATURE."
  (aref signature 1))

(defun epg-signature-user-id (signature)
  "Return the user-id of SIGNATURE."
  (aref signature 2))
  
(defun epg-signature-validity (signature)
  "Return the validity of SIGNATURE."
  (aref signature 3))

(defun epg-signature-set-status (signature status)
 "Set the status code of SIGNATURE."
  (aset signature 0 status))

(defun epg-signature-set-key-id (signature key-id)
 "Set the key-id of SIGNATURE."
  (aset signature 1 key-id))

(defun epg-signature-set-user-id (signature user-id)
 "Set the user-id of SIGNATURE."
  (aset signature 2 user-id))
  
(defun epg-signature-set-validity (signature validity)
 "Set the validity of SIGNATURE."
  (aset signature 3 validity))

(defun epg-start (context args)
  "Start `epg-gpg-program' in a subprocess with given ARGS."
  (let* ((args (append (list "--no-tty"
			     "--status-fd" "1"
			     "--command-fd" "0"
			     "--yes") ; overwrite
		       (if (epg-context-armor context) '("--armor"))
		       (if (epg-context-textmode context) '("--textmode"))
		       (if (epg-context-output-file context)
			   (list "--output" (epg-context-output-file context)))
		       args))
	 (coding-system-for-write 'binary)
	 process-connection-type
	 (orig-mode (default-file-modes))
	 (buffer (generate-new-buffer " *epg*"))
	 process)
    (with-current-buffer buffer
      (make-local-variable 'epg-read-point)
      (setq epg-read-point (point-min))
      (make-local-variable 'epg-pending-status-list)
      (setq epg-pending-status-list nil)
      (make-local-variable 'epg-key-id)
      (setq epg-key-id nil)
      (make-local-variable 'epg-context)
      (setq epg-context context))
    (unwind-protect
	(progn
	  (set-default-file-modes 448)
	  (setq process
		(apply #'start-process "epg" buffer epg-gpg-program args)))
      (set-default-file-modes orig-mode))
    (set-process-filter process #'epg-process-filter)
    (epg-context-set-process context process)))

(defun epg-process-filter (process input)
  (if epg-debug
      (save-excursion
	(set-buffer (get-buffer-create  " *epg-debug*"))
	(goto-char (point-max))
	(insert input)))
  (if (buffer-live-p (process-buffer process))
      (save-excursion
	(set-buffer (process-buffer process))
	(goto-char (point-max))
	(insert input)
	(goto-char epg-read-point)
	(beginning-of-line)
	(while (looking-at ".*\n")	;the input line is finished
	  (save-excursion
	    (if (looking-at "\\[GNUPG:] \\([A-Z_]+\\) ?\\(.*\\)")
		(let* ((status (match-string 1))
		       (string (match-string 2))
		       (symbol (intern-soft (concat "epg-status-" status))))
		  (if (member status epg-pending-status-list)
		      (setq epg-pending-status-list nil))
		  (if (and symbol
			   (fboundp symbol))
		      (funcall symbol process string)))))
	  (forward-line))
	(setq epg-read-point (point)))))

(defun epg-read-output (context)
  (with-temp-buffer
    (set-buffer-multibyte nil)
    (if (file-exists-p (epg-context-output-file context))
	(let ((coding-system-for-read (if (epg-context-output-file context)
					  'raw-text
				      'binary)))
	  (insert-file-contents (epg-context-output-file context))
	  (buffer-string)))))

(defun epg-wait-for-status (context status-list)
  (with-current-buffer (process-buffer (epg-context-process context))
    (setq epg-pending-status-list status-list)
    (while (and (eq (process-status (epg-context-process context)) 'run)
		epg-pending-status-list)
      (accept-process-output (epg-context-process context) 1))))

(defun epg-wait-for-completion (context)
  (process-send-eof (epg-context-process context))
  (while (eq (process-status (epg-context-process context)) 'run)
    ;; We can't use accept-process-output instead of sit-for here
    ;; because it may cause an interrupt during the sentinel execution.
    (sit-for 0.1)))

(defun epg-reset (context)
  (if (and (epg-context-process context)
	   (buffer-live-p (process-buffer (epg-context-process context))))
      (kill-buffer (process-buffer (epg-context-process context))))
  (epg-context-set-process context nil)
  (if (file-exists-p (epg-context-output-file context))
      (delete-file (epg-context-output-file context)))
  (aset context 9 nil))

(defun epg-status-USERID_HINT (process string)
  (if (string-match "\\`\\([^ ]+\\) \\(.*\\)" string)
      (let* ((key-id (match-string 1 string))
	     (user-id (match-string 2 string))
	     (entry (assoc key-id epg-user-id-alist)))
	(if entry
	    (setcdr entry user-id)
	  (setq epg-user-id-alist (cons (cons key-id user-id)
					epg-user-id-alist))))))

(defun epg-status-NEED_PASSPHRASE (process string)
  (if (string-match "\\`\\([^ ]+\\)" string)
      (setq epg-key-id (match-string 1 string))))

(defun epg-status-NEED_PASSPHRASE_SYM (process string)
  (setq epg-key-id 'SYM))

(defun epg-status-NEED_PASSPHRASE_PIN (process string)
  (setq epg-key-id 'PIN))

(defun epg-status-GET_HIDDEN (process string)
  (let ((passphrase (funcall
		     (car (epg-context-passphrase-callback epg-context))
		     epg-key-id
		     (cdr (epg-context-passphrase-callback epg-context)))))
    (unwind-protect
	(if passphrase
	    (process-send-string process (concat passphrase "\n")))
      (fillarray passphrase 0))))

(defun epg-status-GOODSIG (process string)
  (if (string-match "\\`\\([^ ]+\\) \\(.*\\)" string)
      (epg-context-set-result
       epg-context
       'verify
       (cons (epg-make-signature 'good
				 (match-string 1 string)
				 (match-string 2 string))
	     (epg-context-result epg-context 'verify)))))

(defun epg-status-EXPSIG (process string)
  (if (string-match "\\`\\([^ ]+\\) \\(.*\\)" string)
      (epg-context-set-result
       epg-context
       'verify
       (cons (epg-make-signature 'expired
				 (match-string 1 string)
				 (match-string 2 string))
	     (epg-context-result epg-context 'verify)))))

(defun epg-status-EXPKEYSIG (process string)
  (if (string-match "\\`\\([^ ]+\\) \\(.*\\)" string)
      (epg-context-set-result
       epg-context
       'verify
       (cons (epg-make-signature 'expired-key
				 (match-string 1 string)
				 (match-string 2 string))
	     (epg-context-result epg-context 'verify)))))

(defun epg-status-REVKEYSIG (process string)
  (if (string-match "\\`\\([^ ]+\\) \\(.*\\)" string)
      (epg-context-set-result
       epg-context
       'verify
       (cons (epg-make-signature 'revoked-key
				 (match-string 1 string)
				 (match-string 2 string))
	     (epg-context-result epg-context 'verify)))))

(defun epg-status-BADSIG (process string)
  (if (string-match "\\`\\([^ ]+\\) \\(.*\\)" string)
      (epg-context-set-result
       epg-context
       'verify
       (cons (epg-make-signature 'bad
				 (match-string 1 string)
				 (match-string 2 string))
	     (epg-context-result epg-context 'verify)))))

(defun epg-status-TRUST_UNDEFINED (process string)
  (let ((signature (car (epg-context-result epg-context 'verify))))
    (if (and signature
	     (eq (epg-signature-status signature) 'good))
	(epg-signature-set-validity signature 'unknown))))

(defun epg-status-TRUST_NEVER (process string)
  (let ((signature (car (epg-context-result epg-context 'verify))))
    (if (and signature
	     (eq (epg-signature-status signature) 'good))
	(epg-signature-set-validity signature 'never))))

(defun epg-status-TRUST_MARGINAL (process string)
  (let ((signature (car (epg-context-result epg-context 'verify))))
    (if (and signature
	     (eq (epg-signature-status signature) 'marginal))
	(epg-signature-set-validity signature 'marginal))))

(defun epg-status-TRUST_FULLY (process string)
  (let ((signature (car (epg-context-result epg-context 'verify))))
    (if (and signature
	     (eq (epg-signature-status signature) 'good))
	(epg-signature-set-validity signature 'full))))

(defun epg-status-TRUST_ULTIMATE (process string)
  (let ((signature (car (epg-context-result epg-context 'verify))))
    (if (and signature
	     (eq (epg-signature-status signature) 'good))
	(epg-signature-set-validity signature 'full))))

(defun epg-status-DECRYPTION_FAILED (process string)
  (epg-context-set-result epg-context 'decrypt 'failed))

(defun epg-status-PROGRESS (process string)
  (if (string-match "\\`\\([^ ]+\\) \\([^ ]\\) \\([0-9]+\\) \\([0-9]+\\)"
		    string)
      (funcall (car (epg-context-progress-callback epg-context))
	       (match-string 1 string)
	       (match-string 2 string)
	       (string-to-number (match-string 3 string))
	       (string-to-number (match-string 4 string)))))

(defun epg-passphrase-callback (key-id handback)
  (read-passwd
   (if (eq key-id 'SYM)
       "GnuPG passphrase for symmetric encryption: "
     (if (eq key-id 'PIN)
	 "GnuPG passphrase for PIN: "
       (format "GnuPG passphrase for %s: "
	       (let ((entry (assoc key-id epg-user-id-alist)))
		 (if entry
		     (cdr entry)
		   key-id)))))))

(defun epg-progress-callback (what char current total handback)
  (message "%s: %d%%/%d%%" what current total))

(defun epg-list-keys (name &optional secret)
  "List keys associated with STRING."
  (let ((args (list "--with-colons" "--no-greeting" "--batch"
		    "--fixed-list-mode"
		    (if secret "--list-secret-keys" "--list-keys")
		    name))
	keys type symbol pointer)
    (with-temp-buffer
      (apply #'call-process epg-gpg-program nil (list t nil) nil args)
      (goto-char (point-min))
      (while (looking-at "\\([a-z][a-z][a-z]\\):\\(.*\\)")
	(setq type (match-string 1)
	      symbol (intern-soft (format "epg-colons-%s-spec" type)))
	(if (member type '("pub" "sec"))
	    (setq keys (cons nil keys)))
	(if (and symbol
		 (boundp symbol))
	    (setcar keys (cons (cons (intern type)
				     (epg-parse-colons
				      (symbol-value symbol)
				      (match-string 2)))
			       (car keys))))
	(forward-line)))
    (setq pointer keys)
    (while pointer
      (setcar pointer (nreverse (car pointer)))
      (setq pointer (cdr pointer)))
    (nreverse keys)))

(defun epg-parse-colons (alist string)
  (let ((index 0)
	result)
    (while (and alist
		(or (null (car alist))
		    (eq index
			(string-match
			 (concat "\\(" (nth 1 (car alist)) "\\)?:")
			 string index))))
      (if (car alist)
	  (progn
	    (setq index (match-end 0))
	    (if (match-beginning 1)
		(setq result
		      (cons (cons (car (car alist))
				  (funcall (or (nth 3 (car alist)) #'identity)
					   (match-string
					    (1+ (or (nth 2 (car alist)) 0))
					    string)))
			    result))))
	(setq index (1+ index)))
      (setq alist (cdr alist)))
    (nreverse result)))

;;;###autoload
(defun epg-decrypt-start (context input-file)
  "Initiate a decrypt operation."
  (epg-context-set-output-file context (epg-make-temp-file "epg-output"))
  (epg-start context
	     (list "--decrypt" input-file))
  (epg-wait-for-status context '("BEGIN_DECRYPTION")))

;;;###autoload
(defun epg-decrypt-string (context string)
  "Decrypt STRING."
  (let ((input-file (epg-make-temp-file "epg-input"))
	(coding-system-for-write 'binary))
    (unwind-protect
	(progn
	  (write-region string nil input-file)
	  (epg-decrypt-start context input-file)
	  (epg-wait-for-completion context)
	  (unless (epg-context-result context 'decrypt)
	    (epg-read-output context)))
      (epg-reset context)
      (if (file-exists-p input-file)
	  (delete-file input-file)))))

;;;###autoload
(defun epg-verify-start (context signature &optional string)
  "Initiate a verify operation."
  (epg-context-set-output-file context (epg-make-temp-file "epg-output"))
  (if string
      ;; Detached signature.
      (progn
	(epg-start context
		   (append (list "--verify")
			   (list signature "-")))
	(if (eq (process-status (epg-context-process context)) 'run)
	    (process-send-string (epg-context-process context) string)))
    ;; Normal (or cleartext) signature.
    (epg-start context
	       (list "--verify"))
    (if (eq (process-status (epg-context-process context)) 'run)
	(process-send-string (epg-context-process context) signature))))

;;;###autoload
(defun epg-verify-string (context signature &optional string)
  "Verify SIGNATURE."
  (let ((input-file (epg-make-temp-file "epg-input"))
	(coding-system-for-write 'binary))
    (unwind-protect
	(progn
	  (if string
	      (write-region signature nil input-file))
	  (epg-verify-start context input-file string)
	  (epg-wait-for-completion context)
	  (epg-context-result context 'verify))
      (epg-reset context)
      (if (file-exists-p input-file)
	  (delete-file input-file)))))

;;;###autoload
(defun epg-sign-start (context string &optional mode)
  "Initiate a sign operation."
  (epg-context-set-output-file context (epg-make-temp-file "epg-output"))
  (epg-start context
	     (append (list (if (null mode)
			       "--sign"
			     (if (or (eq mode t) (eq mode 'detached))
				 "--detach-sign"
			       "--clearsign")))
		     (apply #'nconc
			    (mapcar (lambda (signer)
				      (list "-u" signer))
				    (epg-context-signers context)))))
  (epg-wait-for-status context '("BEGIN_SIGNING"))
  (if (eq (process-status (epg-context-process context)) 'run)
      (process-send-string (epg-context-process context) string)))

;;;###autoload
(defun epg-sign-string (context string &optional mode)
  "Sign STRING."
  (unwind-protect
      (progn
	(epg-sign-start context string mode)
	(epg-wait-for-completion context)
	(epg-read-output context))
    (epg-reset context)))

;;;###autoload
(defun epg-encrypt-start (context string recipients
				  &optional always-trust sign)
  "Initiate a encrypt operation."
  (epg-context-set-output-file context (epg-make-temp-file "epg-output"))
  (epg-start context
	     (append (if always-trust '("--always-trust"))
		     (if recipients '("--encrypt") '("--symmetric"))
		     (if sign
			 (cons "--sign"
			       (apply #'nconc
				      (mapcar (lambda (signer)
						(list "-u" signer))
					      (epg-context-signers context)))))
		     (apply #'nconc
			    (mapcar (lambda (recipient)
				      (list "-r" recipient))
				    recipients))))
  (if sign
      (epg-wait-for-status context '("BEGIN_SIGNING")))
  (if (eq (process-status (epg-context-process context)) 'run)
      (process-send-string (epg-context-process context) string)))

;;;###autoload
(defun epg-encrypt-string (context string recipients
				   &optional always-trust sign)
  "Encrypt STRING."
  (unwind-protect
      (progn
	(epg-encrypt-start context string recipients always-trust sign)
	(epg-wait-for-completion context)
	(epg-read-output context))
    (epg-reset context)))

(provide 'epg)

;;; epg.el ends here