lisp/liece-crypt.el

   1 ;;; liece-crypt.el --- Encryption/Decryption facility for conversation.
   2 ;; Copyright (C) 1998-2000 Daiki Ueno
   3
   4 ;; Author: Daiki Ueno <ueno@unixuser.org>
   5 ;; Created: 1998-09-28
   6 ;; Revised: 1999-02-07
   7 ;; Keywords: IRC, liece
   8
   9 ;; This file is part of Liece.
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26
  27 ;;; Commentary:
  28 ;;
  29
  30 ;;; Code:
  31
  32 (eval-when-compile
  33   (require 'liece-inlines)
  34   (require 'liece-misc))
  35
  36 (autoload 'crc32-string "crc32")
  37
  38 (defgroup liece-crypt nil
  39   "Crypt customization group"
  40   :tag "Crypt"
  41   :prefix "liece-"
  42   :group 'liece)
  43
  44 (defcustom liece-crypt-decryption-keys nil
  45   "String list containing decryption keys.  e.g. '(\"foo\" \"bar\")."
  46   :type '(repeat (string :tag "Key"))
  47   :group 'liece-crypt)
  48
  49 (defcustom liece-crypt-encryption-keys nil
  50   "List containing pairs of addresses and associated default keys."
  51   :type '(repeat (cons (string :tag "Channel")
  52                        (string :tag "key")))
  53   :group 'liece-crypt)
  54
  55 (defcustom liece-crypt-timestamp-tolerance 300
  56   "Allow incoming messages to have N seconds old timestamp."
  57   :type 'integer
  58   :group 'liece-crypt)
  59
  60 (defcustom liece-crypt-default-cipher-algorithm 'idea
  61   "Cipher algorithm."
  62   :group 'liece-crypt)
  63
  64 (defcustom liece-crypt-default-hash-function
  65   (function liece-crypt-hash-crc32-string)
  66   "Cipher algorithm."
  67   :type 'function
  68   :group 'liece-crypt)
  69
  70 (defconst liece-crypt-encrypt-message-format "|*E*|%s|%s|%s|%s|")
  71
  72 (defvar liece-crypt-mode-active nil
  73   "If t, liece encrypts all messages it has a default key for.")
  74
  75 (defun liece-crypt-encrypted-message-p (message)
  76   (string-match "^|\\*E\\*|[^|]*|[0-9][0-9]*\\.[0-9][0-9]*|[^|]*|[^|]*|$"
  77                 message))
  78
  79 (defun liece-crypt-hash-crc32-string (string)
  80   (let ((r (make-string 9 0)) (s (make-string 9 0)))
  81     (aset r 8 0)
  82     (aset r 7 (logand (nth 0 string) 255))
  83     (aset r 6 (logand (lsh (nth 0 string) -8) 255))
  84     (aset r 5 (logand (nth 1 string) 255))
  85     (aset r 4 (logand (lsh (nth 1 string) -8) 255))
  86     (aset r 3 (logand (nth 2 string) 255))
  87     (aset r 2 (logand (lsh (nth 2 string) -8) 255))
  88     (aset r 1 (logand (nth 3 string) 255))
  89     (aset r 0 (logand (lsh (nth 3 string) -8) 255))
  90     (aset s 8 255)
  91     (aset s 7 (logand (nth 4 string) 255))
  92     (aset s 6 (logand (lsh (nth 4 string) -8) 255))
  93     (aset s 5 (logand (nth 5 string) 255))
  94     (aset s 4 (logand (lsh (nth 5 string) -8) 255))
  95     (aset s 3 (logand (nth 6 string) 255))
  96     (aset s 2 (logand (lsh (nth 6 string) -8) 255))
  97     (aset s 1 (logand (nth 7 string) 255))
  98     (aset s 0 (logand (lsh (nth 7 string) -8) 255))
  99     (setq s (concat (crc32-string (concat r s)) s))
 100     (setq r (concat (crc32-string (concat s r)) r))
 101     (substring (crc32-string r) 0 6)
 102     (substring (crc32-string s) 0 6)))
 103
 104 (defun liece-crypt-key-fingerprint (key &optional algorithm)
 105   (let* ((algorithm (or algorithm liece-crypt-default-cipher-algorithm))
 106          (func (intern (concat (symbol-name algorithm)
 107                                "-key-fingerprint"))))
 108     (if (fboundp func)
 109         (funcall (symbol-function func) key)
 110       (funcall liece-crypt-default-hash-function key))))
 111
 112 (defun liece-crypt-algorithm-major-version (&optional algorithm)
 113   (let ((algorithm (or algorithm liece-crypt-default-cipher-algorithm))
 114         (major (intern (concat (symbol-name algorithm) "-major-version"))))
 115     (if (boundp major)
 116         (symbol-value major))))
 117
 118 (defun liece-crypt-algorithm-minor-version (&optional algorithm)
 119   (let ((algorithm (or algorithm liece-crypt-default-cipher-algorithm))
 120         (minor (intern (concat (symbol-name algorithm) "-minor-version"))))
 121     (if (boundp minor)
 122         (symbol-value minor))))
 123
 124 (defun liece-crypt-build-decryption-key (key &optional algorithm)
 125   (let* ((algorithm (or algorithm liece-crypt-default-cipher-algorithm))
 126          (func (symbol-function
 127                 (intern (concat (symbol-name algorithm)
 128                                 "-build-decryption-key")))))
 129     (funcall func key)))
 130
 131 (defun liece-crypt-build-encryption-key (key &optional algorithm)
 132   (let* ((algorithm (or algorithm liece-crypt-default-cipher-algorithm))
 133          (func (symbol-function
 134                 (intern (concat (symbol-name algorithm)
 135                                 "-build-encryption-key")))))
 136     (funcall func key)))
 137
 138 (defun liece-crypt-decrypt-string (string key &optional algorithm mode)
 139   (let* ((algorithm (or algorithm liece-crypt-default-cipher-algorithm))
 140          (mode (or mode "cbc"))
 141          (func (intern (format "%s-%s-decrypt-string"
 142                                (symbol-name algorithm)
 143                                mode))))
 144     (if (fboundp func)
 145         (funcall (symbol-function func) string key)
 146       (error (_ "Mode `%s' is not available.") (upcase mode)))))
 147
 148 (defun liece-crypt-encrypt-string (string key &optional algorithm mode)
 149   (let* ((algorithm (or algorithm liece-crypt-default-cipher-algorithm))
 150          (mode (or mode "cbc"))
 151          (func (intern (format "%s-%s-encrypt-string"
 152                                (symbol-name algorithm)
 153                                mode))))
 154     (if (fboundp func)
 155         (funcall (symbol-function func) string key)
 156       (error (_ "Mode `%s' is not available.") (upcase mode)))))
 157
 158 (defun liece-crypt-valid-version-p (algorithm major-version minor-version)
 159   (let (major minor)
 160     (setq major (liece-crypt-algorithm-major-version algorithm)
 161           minor (liece-crypt-algorithm-minor-version algorithm))
 162     (cond
 163      ((and major minor)
 164       (and (= (symbol-value major) major-version)
 165            (>= (symbol-value minor) minor-version)))
 166      (t nil))))
 167
 168 (defun liece-crypt-import-cipher-algorithm (algorithm &optional no-error)
 169   (let ((algorithm (symbol-name algorithm)))
 170     (or (eval `(featurep ',(intern algorithm)))
 171         (load algorithm t)
 172         (unless no-error
 173           (error (_ "Unknown algorithm `%s'") (upcase algorithm))))))
 174
 175 (defun liece-crypt-initialize ()
 176   "Initialize crypt variables."
 177   (let ((keys (copy-sequence liece-crypt-decryption-keys)))
 178     (setq liece-crypt-decryption-keys nil)
 179     (dolist (key keys)
 180       (liece-command-add-decryption-key key)))
 181   (let ((keys (copy-sequence liece-crypt-encryption-keys)))
 182     (setq liece-crypt-encryption-keys nil)
 183     (dolist (key keys)
 184       (liece-command-set-encryption-key (car key) (cdr key))))
 185   (liece-crypt-reset-variables))
 186
 187 (defmacro liece-crypt-reset-variables ()
 188   '(setq liece-message-encrypted-p nil
 189          liece-message-suspicious-p nil
 190          liece-message-garbled-p nil
 191          liece-message-fingerprint nil
 192          liece-message-timestamp nil))
 193
 194 \f
 195 ;;;###liece-autoload
 196 (defun liece-set-crypt-indicator ()
 197   "Set crypt mode indicator."
 198   (setq liece-crypt-indicator
 199         (cond ((and liece-crypt-mode-active
 200                     (eq liece-command-buffer-mode 'channel)
 201                     liece-current-channel
 202                     liece-crypt-encryption-keys
 203                     (string-assoc-ignore-case liece-current-channel
 204                                               liece-crypt-encryption-keys))
 205                "C")
 206               ((and liece-crypt-mode-active
 207                     (eq liece-command-buffer-mode 'chat)
 208                     liece-current-chat-partner
 209                     liece-crypt-encryption-keys
 210                     (string-assoc-ignore-case liece-current-chat-partner
 211                                               liece-crypt-encryption-keys))
 212                "C")
 213               (liece-crypt-mode-active "c")
 214               (t "-"))))
 215
 216 ;;;###liece-autoload
 217 (defun liece-command-add-decryption-key (key-var &optional algorithm)
 218   "Add new KEY to known decryption keys list."
 219   (interactive
 220    (let ((passwd-echo ?*))
 221      (list (read-passwd "Add passphrase: "))))
 222   (let ((algorithm (or algorithm liece-crypt-default-cipher-algorithm))
 223         key fingerprint)
 224     (liece-crypt-import-cipher-algorithm algorithm)
 225     (setq key (if (stringp key-var)
 226                   (liece-crypt-build-decryption-key key-var)
 227                 key-var)
 228           fingerprint (liece-crypt-key-fingerprint key))
 229     (set-alist 'liece-crypt-decryption-keys fingerprint key)
 230     (when (interactive-p)
 231       (liece-message (_ "Added new decryption key (%s).") fingerprint))))
 232
 233 ;;;###liece-autoload
 234 (defun liece-command-delete-decryption-key (key-var &optional algorithm)
 235   "Delete a KEY from known decryption keys list."
 236   (interactive
 237    (let ((passwd-echo ?*))
 238      (list (read-passwd (_ "Delete passphrase: ")))))
 239   (let ((algorithm (or algorithm liece-crypt-default-cipher-algorithm))
 240         fingerprint)
 241     (liece-crypt-import-cipher-algorithm algorithm)
 242     (setq fingerprint (liece-crypt-key-fingerprint key-var))
 243     (remove-alist 'liece-crypt-decryption-keys fingerprint)
 244       (when (interactive-p)
 245         (liece-message (_ "Removed decryption key (%s).") fingerprint))))
 246
 247 ;;;###liece-autoload
 248 (defun liece-command-set-encryption-key
 249   (addr-var pass-var &optional algorithm)
 250   "Set a default key for ADDRESS (channel/nick) to be KEY."
 251   (interactive
 252    (let ((addr-var
 253           (liece-minibuffer-completing-default-read
 254            (_ "Default key for channel/user: ")
 255            (append liece-nick-alist liece-channel-alist)
 256            nil nil liece-privmsg-partner))
 257          pass-var)
 258      (let ((passwd-echo ?*))
 259        (setq pass-var (read-passwd (_ "Passphrase: "))))
 260      (when (string-equal pass-var "")
 261        (setq pass-var nil))
 262      (list addr-var pass-var)))
 263   (let ((algorithm (or algorithm liece-crypt-default-cipher-algorithm))
 264         (addr-var (upcase addr-var)) ek dk fingerprint)
 265     (liece-crypt-import-cipher-algorithm algorithm)
 266     (cond
 267      ((null pass-var)
 268       (remove-alist 'liece-crypt-encryption-keys addr-var)
 269       (liece-message (_ "Removed a default key from \"%s\".")
 270                       addr-var))
 271      (t
 272       (setq ek (liece-crypt-build-encryption-key pass-var)
 273             dk (liece-crypt-build-decryption-key pass-var)
 274             fingerprint (liece-crypt-key-fingerprint dk))
 275       (liece-command-add-decryption-key dk)
 276       (set-alist 'liece-crypt-encryption-keys
 277                  addr-var (list fingerprint ek dk))
 278       (when (interactive-p)
 279         (liece-message (_ "Added a default key for \"%s\".") addr-var))
 280       (liece-set-crypt-indicator)))))
 281
 282 (defun liece-make-encrypted-message (message key &optional algorithm)
 283   "Build an encrypted message from MESSAGE with KEY."
 284   (let ((algorithm (or algorithm liece-crypt-default-cipher-algorithm)))
 285     (format liece-crypt-encrypt-message-format
 286             (upcase (symbol-name algorithm))
 287             (let ((major (liece-crypt-algorithm-major-version algorithm))
 288                   (minor (liece-crypt-algorithm-minor-version algorithm)))
 289               (cond
 290                ((and major minor)
 291                 (format "%d.%d" major minor))
 292                (t "1.0")))
 293             (liece-crypt-key-fingerprint key)
 294             (liece-crypt-encrypt-string message key algorithm))))
 295
 296 (defun liece-encrypt-message (message address &optional no-clear-text)
 297   "Encrypt MESSAGE to ADDRESS.  NO-CLEAR-TEXT prohibits cleartext output."
 298   (let ((key
 299          (caddr
 300           (assoc-if
 301            `(lambda (item)
 302               (string-match (concat "^" (upcase item) "$") (upcase ,address)))
 303            liece-crypt-encryption-keys)))
 304         (message (liece-coding-encode-charset-string message)))
 305     (cond
 306      ((and no-clear-text (null key))
 307       (error (_ "No default key associated with \"%s\".") address))
 308      ((null key) message)
 309      (t
 310       (liece-make-encrypted-message
 311        (format "%s\001%s\001%s"
 312                (liece-current-nickname)
 313                (liece-generate-hex-timestamp)
 314                message)
 315        key)))))
 316
 317 (defmacro liece-crypt-decrypt-fail (&optional value)
 318   `(throw 'failed ,value))
 319
 320 (defun liece-decrypt-message (message)
 321   "Decrypt MESSAGE."
 322   (if (string-match "^|\\*E\\*|\\([^|]*\\)|\\([0-9][0-9]*\\)\\.\\([0-9][0-9]*\\)|\\([^|]*\\)|\\([^|]*\\)|$" message)
 323       (let ((algorithm (intern (downcase (substring message
 324                                                     (match-beginning 1)
 325                                                     (match-end 1)))))
 326             (version-major (string-to-number (match-string 2 message)))
 327             (version-minor (string-to-number (match-string 3 message)))
 328             (fingerprint (match-string 4 message))
 329             (msg (match-string 5 message))
 330             key r)
 331         (catch 'failed
 332           (or (liece-crypt-import-cipher-algorithm algorithm 'no-error)
 333               (liece-crypt-decrypt-fail
 334                (list 'error nil nil (_ "Unknown algorithm")
 335                      fingerprint)))
 336           (or (liece-crypt-valid-version-p
 337                algorithm version-major version-minor)
 338               (liece-crypt-decrypt-fail
 339                (list 'error nil nil (_ "Unknown version")
 340                      fingerprint)))
 341           (or (setq key (cdr (assoc fingerprint liece-crypt-decryption-keys)))
 342               (liece-crypt-decrypt-fail
 343                (list 'error nil nil (_ "No key")
 344                      fingerprint)))
 345           (or (setq r (liece-crypt-decrypt-string msg key))
 346               (liece-crypt-decrypt-fail
 347                (list 'error nil nil (_ "Decryption failed")
 348                      fingerprint)))
 349           (or (string-match "^\\([^\001][^\001]*\\)\001\\([^\001][^\001]*\\)\001\\(.*\\)$" r)
 350               (liece-crypt-decrypt-fail
 351                (list 'error nil nil (_ "Invalid cleartext format")
 352                      fingerprint)))
 353           (list 'success
 354                 (match-string 1 r)
 355                 (match-string 2 r)
 356                 (liece-coding-decode-charset-string (match-string 3 r))
 357                 fingerprint)))
 358     (list 'error nil nil (_ "Invalid message!") nil)))
 359
 360 (defun liece-crypt-maybe-decrypt-message (message sender)
 361   (let (head tail clear stat nick time msg fprint warn)
 362     (when (string-match "^\\([^ ]+\\) :\\(.*\\)" message)
 363       (setq head (match-string 1 message)
 364             tail (match-string 2 message))
 365       (when (liece-crypt-encrypted-message-p tail)
 366         (setq clear (liece-decrypt-message tail)
 367               stat (nth 0 clear)   ;; 'success or 'error
 368               nick (nth 1 clear)   ;;  sender's nick
 369               time (nth 2 clear)   ;;  timestamp
 370               msg (nth 3 clear)   ;;  cleartext msg
 371               fprint (nth 4 clear) ;;  fingerprint
 372               warn ""
 373               liece-message-encrypted-p t
 374               liece-message-fingerprint fprint
 375               liece-message-timestamp time)
 376         ;; Check timestamp and nick here
 377         (cond
 378          ((equal 'success stat)
 379           (setq liece-message-suspicious-p t)
 380           (or (liece-hex-timestamp-valid
 381                time liece-crypt-timestamp-tolerance)
 382               (setq warn (concat warn " [Invalid timestamp!]")))
 383           (or (liece-nick-equal nick sender)
 384               (setq warn (format
 385                           "%s [Invalid sender \"%s\" != \"%s\"]"
 386                           warn nick sender))))
 387          (t
 388           (setq liece-message-garbled-p t)
 389           (liece-insert liece-C-buffer
 390                          (format "<%s -> %s> %s [%s]\n"
 391                                  sender head tail msg))))
 392         (setq message (format "%s :%s%s" head msg warn))))
 393     message))
 394
 395 (defun liece-crypt-maybe-encrypt-message (message addr arg key)
 396   "Encrypt MESSAGE when `liece-crypt-mode' is active."
 397   (if (or (and arg addr) key)
 398       (setq liece-message-encrypted-p t
 399             message (liece-encrypt-message message addr t))
 400     (setq liece-message-encrypted-p nil))
 401   message)
 402
 403 (defmacro with-liece-decryption (args &rest body)
 404   `(let (liece-message-encrypted-p
 405          liece-message-suspicious-p
 406          liece-message-garbled-p
 407          liece-message-fingerprint
 408          liece-message-timestamp)
 409      (setq ,(car args)
 410            (funcall #'liece-crypt-maybe-decrypt-message ,@args))
 411      ,@body))
 412
 413 (defmacro with-liece-encryption (args &rest body)
 414   `(let (liece-message-encrypted-p
 415          liece-message-suspicious-p
 416          liece-message-garbled-p
 417          liece-message-fingerprint
 418          liece-message-timestamp)
 419      (setq ,(car args)
 420            (funcall #'liece-crypt-maybe-encrypt-message ,@args))
 421      ,@body))
 422
 423 (put 'with-liece-decryption 'lisp-indent-function 1)
 424 (put 'with-liece-encryption 'lisp-indent-function 1)
 425
 426 (provide 'liece-crypt)
 427
 428 ;;; liece-crypt.el ends here