;;; liece-crypt.el --- Encryption/Decryption facility for conversation.
;; Copyright (C) 1998-2000 Daiki Ueno

;; Author: Daiki Ueno <ueno@unixuser.org>
;; Created: 1998-09-28
;; Revised: 1999-02-07
;; Keywords: IRC, liece

;; This file is part of Liece.

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	 See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.


;;; Commentary:
;; 

;;; Code:

(eval-when-compile
  (require 'liece-inlines)
  (require 'liece-misc))

(autoload 'crc32-string "crc32")

(defgroup liece-crypt nil
  "Crypt customization group"
  :tag "Crypt"
  :prefix "liece-"
  :group 'liece)

(defcustom liece-crypt-decryption-keys nil
  "String list containing decryption keys.  e.g. '(\"foo\" \"bar\")."
  :type '(repeat (string :tag "Key"))
  :group 'liece-crypt)

(defcustom liece-crypt-encryption-keys nil
  "List containing pairs of addresses and associated default keys."
  :type '(repeat (cons (string :tag "Channel")
		       (string :tag "key")))
  :group 'liece-crypt)
  
(defcustom liece-crypt-timestamp-tolerance 300
  "Allow incoming messages to have N seconds old timestamp."
  :type 'integer
  :group 'liece-crypt)

(defcustom liece-crypt-default-cipher-algorithm 'idea
  "Cipher algorithm."
  :group 'liece-crypt)

(defcustom liece-crypt-default-hash-function
  (function liece-crypt-hash-crc32-string)
  "Cipher algorithm."
  :type 'function
  :group 'liece-crypt)

(defconst liece-crypt-encrypt-message-format "|*E*|%s|%s|%s|%s|")

(defvar liece-crypt-mode-active nil
  "If t, liece encrypts all messages it has a default key for.")

(defun liece-crypt-encrypted-message-p (message)
  (string-match "^|\\*E\\*|[^|]*|[0-9][0-9]*\\.[0-9][0-9]*|[^|]*|[^|]*|$"
		message))

(defun liece-crypt-hash-crc32-string (string)
  (let ((r (make-string 9 0)) (s (make-string 9 0)))
    (aset r 8 0)
    (aset r 7 (logand (nth 0 string) 255))
    (aset r 6 (logand (lsh (nth 0 string) -8) 255))
    (aset r 5 (logand (nth 1 string) 255))
    (aset r 4 (logand (lsh (nth 1 string) -8) 255))
    (aset r 3 (logand (nth 2 string) 255))
    (aset r 2 (logand (lsh (nth 2 string) -8) 255))
    (aset r 1 (logand (nth 3 string) 255))
    (aset r 0 (logand (lsh (nth 3 string) -8) 255))
    (aset s 8 255)
    (aset s 7 (logand (nth 4 string) 255))
    (aset s 6 (logand (lsh (nth 4 string) -8) 255))
    (aset s 5 (logand (nth 5 string) 255))
    (aset s 4 (logand (lsh (nth 5 string) -8) 255))
    (aset s 3 (logand (nth 6 string) 255))
    (aset s 2 (logand (lsh (nth 6 string) -8) 255))
    (aset s 1 (logand (nth 7 string) 255))
    (aset s 0 (logand (lsh (nth 7 string) -8) 255))
    (setq s (concat (crc32-string (concat r s)) s))
    (setq r (concat (crc32-string (concat s r)) r))
    (substring (crc32-string r) 0 6)
    (substring (crc32-string s) 0 6)))
  
(defun liece-crypt-key-fingerprint (key &optional algorithm)
  (let* ((algorithm (or algorithm liece-crypt-default-cipher-algorithm))
	 (func (intern (concat (symbol-name algorithm)
			       "-key-fingerprint"))))
    (if (fboundp func)
	(funcall (symbol-function func) key)
      (funcall liece-crypt-default-hash-function key))))

(defun liece-crypt-algorithm-major-version (&optional algorithm)
  (let ((algorithm (or algorithm liece-crypt-default-cipher-algorithm))
	(major (intern (concat (symbol-name algorithm) "-major-version"))))
    (if (boundp major)
	(symbol-value major))))

(defun liece-crypt-algorithm-minor-version (&optional algorithm)
  (let ((algorithm (or algorithm liece-crypt-default-cipher-algorithm))
	(minor (intern (concat (symbol-name algorithm) "-minor-version"))))
    (if (boundp minor)
	(symbol-value minor))))

(defun liece-crypt-build-decryption-key (key &optional algorithm)
  (let* ((algorithm (or algorithm liece-crypt-default-cipher-algorithm))
	 (func (symbol-function
		(intern (concat (symbol-name algorithm)
				"-build-decryption-key")))))
    (funcall func key)))

(defun liece-crypt-build-encryption-key (key &optional algorithm)
  (let* ((algorithm (or algorithm liece-crypt-default-cipher-algorithm))
	 (func (symbol-function
		(intern (concat (symbol-name algorithm)
				"-build-encryption-key")))))
    (funcall func key)))

(defun liece-crypt-decrypt-string (string key &optional algorithm mode)
  (let* ((algorithm (or algorithm liece-crypt-default-cipher-algorithm))
	 (mode (or mode "cbc"))
	 (func (intern (format "%s-%s-decrypt-string"
			       (symbol-name algorithm)
			       mode))))
    (if (fboundp func)
	(funcall (symbol-function func) string key)
      (error (_ "Mode `%s' is not available.") (upcase mode)))))

(defun liece-crypt-encrypt-string (string key &optional algorithm mode)
  (let* ((algorithm (or algorithm liece-crypt-default-cipher-algorithm))
	 (mode (or mode "cbc"))
	 (func (intern (format "%s-%s-encrypt-string"
			       (symbol-name algorithm)
			       mode))))
    (if (fboundp func)
	(funcall (symbol-function func) string key)
      (error (_ "Mode `%s' is not available.") (upcase mode)))))

(defun liece-crypt-valid-version-p (algorithm major-version minor-version)
  (let (major minor)
    (setq major (liece-crypt-algorithm-major-version algorithm)
	  minor (liece-crypt-algorithm-minor-version algorithm))
    (cond
     ((and major minor)
      (and (= (symbol-value major) major-version)
	   (>= (symbol-value minor) minor-version)))
     (t nil))))

(defun liece-crypt-import-cipher-algorithm (algorithm &optional no-error)
  (let ((algorithm (symbol-name algorithm)))
    (or (eval `(featurep ',(intern algorithm)))
	(load algorithm t)
	(unless no-error
	  (error (_ "Unknown algorithm `%s'") (upcase algorithm))))))

(defun liece-crypt-initialize ()
  "Initialize crypt variables."
  (let ((keys (copy-sequence liece-crypt-decryption-keys)))
    (setq liece-crypt-decryption-keys nil)
    (dolist (key keys)
      (liece-command-add-decryption-key key)))
  (let ((keys (copy-sequence liece-crypt-encryption-keys)))
    (setq liece-crypt-encryption-keys nil)
    (dolist (key keys)
      (liece-command-set-encryption-key (car key) (cdr key))))
  (liece-crypt-reset-variables))

(defmacro liece-crypt-reset-variables ()
  '(setq liece-message-encrypted-p nil
	 liece-message-suspicious-p nil
	 liece-message-garbled-p nil
	 liece-message-fingerprint nil
	 liece-message-timestamp nil))


;;;###liece-autoload
(defun liece-set-crypt-indicator ()
  "Set crypt mode indicator."
  (setq liece-crypt-indicator
	(cond ((and liece-crypt-mode-active
		    (eq liece-command-buffer-mode 'channel)
		    liece-current-channel
		    liece-crypt-encryption-keys
		    (string-assoc-ignore-case liece-current-channel
					      liece-crypt-encryption-keys))
	       "C")
	      ((and liece-crypt-mode-active
		    (eq liece-command-buffer-mode 'chat)
		    liece-current-chat-partner
		    liece-crypt-encryption-keys
		    (string-assoc-ignore-case liece-current-chat-partner
					      liece-crypt-encryption-keys))
	       "C")
	      (liece-crypt-mode-active "c")
	      (t "-"))))

;;;###liece-autoload
(defun liece-command-add-decryption-key (key-var &optional algorithm)
  "Add new KEY to known decryption keys list."
  (interactive
   (let ((passwd-echo ?*))
     (list (read-passwd "Add passphrase: "))))
  (let ((algorithm (or algorithm liece-crypt-default-cipher-algorithm))
	key fingerprint)
    (liece-crypt-import-cipher-algorithm algorithm)
    (setq key (if (stringp key-var)
		  (liece-crypt-build-decryption-key key-var)
		key-var)
	  fingerprint (liece-crypt-key-fingerprint key))
    (set-alist 'liece-crypt-decryption-keys fingerprint key)
    (when (interactive-p)
      (liece-message (_ "Added new decryption key (%s).") fingerprint))))

;;;###liece-autoload
(defun liece-command-delete-decryption-key (key-var &optional algorithm)
  "Delete a KEY from known decryption keys list."
  (interactive
   (let ((passwd-echo ?*))
     (list (read-passwd (_ "Delete passphrase: ")))))
  (let ((algorithm (or algorithm liece-crypt-default-cipher-algorithm))
	fingerprint)
    (liece-crypt-import-cipher-algorithm algorithm)
    (setq fingerprint (liece-crypt-key-fingerprint key-var))
    (remove-alist 'liece-crypt-decryption-keys fingerprint)
      (when (interactive-p)
	(liece-message (_ "Removed decryption key (%s).") fingerprint))))

;;;###liece-autoload
(defun liece-command-set-encryption-key
  (addr-var pass-var &optional algorithm)
  "Set a default key for ADDRESS (channel/nick) to be KEY."
  (interactive
   (let ((addr-var
	  (liece-minibuffer-completing-default-read
	   (_ "Default key for channel/user: ")
	   (append liece-nick-alist liece-channel-alist)
	   nil nil liece-privmsg-partner))
	 pass-var)
     (let ((passwd-echo ?*))
       (setq pass-var (read-passwd (_ "Passphrase: "))))
     (when (string-equal pass-var "")
       (setq pass-var nil))
     (list addr-var pass-var)))
  (let ((algorithm (or algorithm liece-crypt-default-cipher-algorithm))
	(addr-var (upcase addr-var)) ek dk fingerprint)
    (liece-crypt-import-cipher-algorithm algorithm)
    (cond
     ((null pass-var)
      (remove-alist 'liece-crypt-encryption-keys addr-var)
      (liece-message (_ "Removed a default key from \"%s\".")
		      addr-var))
     (t
      (setq ek (liece-crypt-build-encryption-key pass-var)
	    dk (liece-crypt-build-decryption-key pass-var)
	    fingerprint (liece-crypt-key-fingerprint dk))
      (liece-command-add-decryption-key dk)
      (set-alist 'liece-crypt-encryption-keys
		 addr-var (list fingerprint ek dk))
      (when (interactive-p)
	(liece-message (_ "Added a default key for \"%s\".") addr-var))
      (liece-set-crypt-indicator)))))

(defun liece-make-encrypted-message (message key &optional algorithm)
  "Build an encrypted message from MESSAGE with KEY."
  (let ((algorithm (or algorithm liece-crypt-default-cipher-algorithm)))
    (format liece-crypt-encrypt-message-format
	    (upcase (symbol-name algorithm))
	    (let ((major (liece-crypt-algorithm-major-version algorithm))
		  (minor (liece-crypt-algorithm-minor-version algorithm)))
	      (cond
	       ((and major minor)
		(format "%d.%d" major minor))
	       (t "1.0")))
	    (liece-crypt-key-fingerprint key)
	    (liece-crypt-encrypt-string message key algorithm))))

(defun liece-encrypt-message (message address &optional no-clear-text)
  "Encrypt MESSAGE to ADDRESS.  NO-CLEAR-TEXT prohibits cleartext output."
  (let ((key
	 (caddr
	  (assoc-if
	   `(lambda (item)
	      (string-match (concat "^" (upcase item) "$") (upcase ,address)))
	   liece-crypt-encryption-keys)))
	(message (liece-coding-encode-charset-string message)))
    (cond
     ((and no-clear-text (null key))
      (error (_ "No default key associated with \"%s\".") address))
     ((null key) message)
     (t
      (liece-make-encrypted-message
       (format "%s\001%s\001%s"
	       (liece-current-nickname)
	       (liece-generate-hex-timestamp)
	       message)
       key)))))

(defmacro liece-crypt-decrypt-fail (&optional value)
  `(throw 'failed ,value))

(defun liece-decrypt-message (message)
  "Decrypt MESSAGE."
  (if (string-match "^|\\*E\\*|\\([^|]*\\)|\\([0-9][0-9]*\\)\\.\\([0-9][0-9]*\\)|\\([^|]*\\)|\\([^|]*\\)|$" message)
      (let ((algorithm (intern (downcase (substring message
						    (match-beginning 1)
						    (match-end 1)))))
	    (version-major (string-to-number (match-string 2 message)))
	    (version-minor (string-to-number (match-string 3 message)))
	    (fingerprint (match-string 4 message))
	    (msg (match-string 5 message))
	    key r)
	(catch 'failed
	  (or (liece-crypt-import-cipher-algorithm algorithm 'no-error)
	      (liece-crypt-decrypt-fail
	       (list 'error nil nil (_ "Unknown algorithm")
		     fingerprint)))
	  (or (liece-crypt-valid-version-p
	       algorithm version-major version-minor)
	      (liece-crypt-decrypt-fail
	       (list 'error nil nil (_ "Unknown version")
		     fingerprint)))
	  (or (setq key (cdr (assoc fingerprint liece-crypt-decryption-keys)))
	      (liece-crypt-decrypt-fail
	       (list 'error nil nil (_ "No key")
		     fingerprint)))
	  (or (setq r (liece-crypt-decrypt-string msg key))
	      (liece-crypt-decrypt-fail
	       (list 'error nil nil (_ "Decryption failed")
		     fingerprint)))
	  (or (string-match "^\\([^\001][^\001]*\\)\001\\([^\001][^\001]*\\)\001\\(.*\\)$" r)
	      (liece-crypt-decrypt-fail
	       (list 'error nil nil (_ "Invalid cleartext format")
		     fingerprint)))
	  (list 'success
		(match-string 1 r)
		(match-string 2 r)
		(liece-coding-decode-charset-string (match-string 3 r))
		fingerprint)))
    (list 'error nil nil (_ "Invalid message!") nil)))

(defun liece-crypt-maybe-decrypt-message (message sender)
  (let (head tail clear stat nick time msg fprint warn)
    (when (string-match "^\\([^ ]+\\) :\\(.*\\)" message)
      (setq head (match-string 1 message)
	    tail (match-string 2 message))
      (when (liece-crypt-encrypted-message-p tail)
	(setq clear (liece-decrypt-message tail)
	      stat (nth 0 clear)   ;; 'success or 'error
	      nick (nth 1 clear)   ;;  sender's nick
	      time (nth 2 clear)   ;;  timestamp
	      msg (nth 3 clear)   ;;  cleartext msg
	      fprint (nth 4 clear) ;;  fingerprint
	      warn ""
	      liece-message-encrypted-p t
	      liece-message-fingerprint fprint
	      liece-message-timestamp time)
	;; Check timestamp and nick here
	(cond
	 ((equal 'success stat)
	  (setq liece-message-suspicious-p t)
	  (or (liece-hex-timestamp-valid
	       time liece-crypt-timestamp-tolerance)
	      (setq warn (concat warn " [Invalid timestamp!]")))
	  (or (liece-nick-equal nick sender)
	      (setq warn (format
			  "%s [Invalid sender \"%s\" != \"%s\"]"
			  warn nick sender))))
	 (t
	  (setq liece-message-garbled-p t)
	  (liece-insert liece-C-buffer
			 (format "<%s -> %s> %s [%s]\n"
				 sender head tail msg))))
	(setq message (format "%s :%s%s" head msg warn))))
    message))

(defun liece-crypt-maybe-encrypt-message (message addr arg key)
  "Encrypt MESSAGE when `liece-crypt-mode' is active."
  (if (or (and arg addr) key)
      (setq liece-message-encrypted-p t
	    message (liece-encrypt-message message addr t))
    (setq liece-message-encrypted-p nil))
  message)

(defmacro with-liece-decryption (args &rest body)
  `(let (liece-message-encrypted-p
	 liece-message-suspicious-p
	 liece-message-garbled-p
	 liece-message-fingerprint
	 liece-message-timestamp)
     (setq ,(car args)
	   (funcall #'liece-crypt-maybe-decrypt-message ,@args))
     ,@body))

(defmacro with-liece-encryption (args &rest body)
  `(let (liece-message-encrypted-p
	 liece-message-suspicious-p
	 liece-message-garbled-p
	 liece-message-fingerprint
	 liece-message-timestamp)
     (setq ,(car args)
	   (funcall #'liece-crypt-maybe-encrypt-message ,@args))
     ,@body))
     
(put 'with-liece-decryption 'lisp-indent-function 1)
(put 'with-liece-encryption 'lisp-indent-function 1)
       
(provide 'liece-crypt)

;;; liece-crypt.el ends here