cgit.sxemacs.org Git - riece/blob - lisp/riece-epg.el

   1 ;;; riece-epg.el --- Encrypt/decrypt messages add-on
   2 ;; Copyright (C) 2006 Daiki Ueno
   3
   4 ;; Author: Daiki Ueno <ueno@unixuser.org>
   5 ;; Keywords: IRC, riece
   6
   7 ;; This file is part of Riece.
   8
   9 ;; This program is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; This program is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  22 ;; Boston, MA 02110-1301, USA.
  23
  24 ;;; Code:
  25
  26 (require 'riece-message)
  27 (require 'riece-identity)
  28
  29 (autoload 'epg-make-context "epg")
  30 (autoload 'epg-decrypt-string "epg")
  31 (autoload 'epg-encrypt-string "epg")
  32 (autoload 'epg-passphrase-callback-function "epg")
  33 (autoload 'epg-context-set-passphrase-callback "epg")
  34
  35 (eval-when-compile
  36   (autoload 'riece-command-send-message "riece-commands"))
  37
  38 (defgroup riece-epg nil
  39   "Encrypt/decrypt messages."
  40   :group 'riece)
  41
  42 (defconst riece-epg-description
  43   "Encrypt/decrypt messages.")
  44
  45 (defvar riece-epg-passphrase-alist nil)
  46
  47 (defun riece-epg-passphrase-callback-function (key-id identity)
  48   (if (eq key-id 'SYM)
  49       (let ((entry (riece-identity-assoc identity riece-epg-passphrase-alist))
  50             passphrase)
  51         (or (copy-sequence (cdr entry))
  52             (progn
  53               (unless entry
  54                 (setq entry (list identity)
  55                       riece-epg-passphrase-alist (cons entry
  56                                                  riece-epg-passphrase-alist)))
  57               (setq passphrase (epg-passphrase-callback-function key-id nil))
  58               (setcdr entry (copy-sequence passphrase))
  59               passphrase)))
  60     (epg-passphrase-callback-function key-id nil)))
  61
  62 (defun riece-epg-passphrase-callback-function-for-decrypt (key-id identity)
  63   (if (eq key-id 'SYM)
  64       (let ((entry (riece-identity-assoc identity riece-epg-passphrase-alist))
  65             passphrase)
  66         (if (cdr entry)
  67             (copy-sequence (cdr entry))
  68           (epg-cancel epg-context)))
  69     (epg-passphrase-callback-function key-id nil)))
  70
  71 (defun riece-epg-funcall-clear-passphrase (identity function &rest args)
  72   (condition-case error
  73       (apply function args)
  74     (error
  75      (let ((entry (riece-identity-assoc identity riece-epg-passphrase-alist)))
  76        (if entry
  77            (setq riece-epg-passphrase-alist
  78                  (delq entry riece-epg-passphrase-alist))))
  79      (signal (car error) (cdr error)))))
  80
  81 (defun riece-command-enter-encrypted-message ()
  82   "Encrypt the current line send send it to the current channel."
  83   (interactive)
  84   (let ((context (epg-make-context))
  85         (string (buffer-substring
  86                  (riece-line-beginning-position)
  87                  (riece-line-end-position)))
  88         entry)
  89     (riece-with-server-buffer (riece-identity-server riece-current-channel)
  90       (setq string (riece-encode-coding-string-for-identity
  91                     string
  92                     riece-current-channel)))
  93     (epg-context-set-passphrase-callback
  94      context
  95      (cons #'riece-epg-passphrase-callback-function
  96            riece-current-channel))
  97     (setq string (riece-epg-funcall-clear-passphrase riece-current-channel
  98                                                      #'epg-encrypt-string
  99                                                      context string nil))
 100     (riece-command-send-message
 101      (concat "[encrypted:" (base64-encode-string string t) "]")
 102      nil)
 103     (let ((next-line-add-newlines t))
 104       (next-line 1))))
 105
 106 (defun riece-command-set-passphrase (identity passphrase)
 107   "Set PASSPHRASE associated with IDENTITY."
 108   (interactive
 109    (let ((identity
 110           (riece-completing-read-identity
 111            "Channel/user: "
 112            riece-current-channels nil t nil nil
 113            (riece-format-identity riece-current-channel))))
 114      (list identity
 115            (read-passwd (format "Passphrase for %s: "
 116                                 (riece-format-identity identity))))))
 117   (let ((entry (riece-identity-assoc identity riece-epg-passphrase-alist)))
 118     (if (equal passphrase "")
 119         (if entry
 120             (setq riece-epg-passphrase-alist
 121                   (delq entry riece-epg-passphrase-alist)))
 122       (if entry
 123           (setcdr entry passphrase)
 124         (setq riece-epg-passphrase-alist
 125               (cons (cons identity passphrase)
 126                     riece-epg-passphrase-alist))))))
 127
 128 (defun riece-epg-decrypt-string-for-identity (context cipher target)
 129   (let ((coding-system
 130          (or (riece-coding-system-for-identity target)
 131              riece-default-coding-system)))
 132     (riece-with-server-buffer (riece-identity-server target)
 133       (decode-coding-string
 134        (riece-epg-funcall-clear-passphrase
 135         target
 136         #'epg-decrypt-string
 137         context
 138         (base64-decode-string cipher))
 139        (if (consp coding-system)
 140            (car coding-system)
 141          coding-system)))))
 142
 143 (defun riece-epg-message-filter (message)
 144   (if (get 'riece-epg 'riece-addon-enabled)
 145       (when (string-match "\\`\\[encrypted:\\(.*\\)]"
 146                           (riece-message-text message))
 147         (let ((context (epg-make-context))
 148               (string (match-string 1 (riece-message-text message)))
 149               entry)
 150           (epg-context-set-passphrase-callback
 151            context
 152            (cons #'riece-epg-passphrase-callback-function-for-decrypt
 153                  riece-current-channel))
 154           (condition-case error
 155               (progn
 156                 (riece-message-set-text
 157                  message
 158                  (concat
 159                   "[decrypted:"
 160                   (riece-epg-decrypt-string-for-identity
 161                    context string (riece-message-target message))
 162                   "]")))
 163             (error
 164              (riece-put-text-property-nonsticky
 165               0 (length (riece-message-text message))
 166               'riece-epg-encryption-target (riece-message-target message)
 167               (riece-message-text message))
 168              (message "%s" (cdr error)))))))
 169   message)
 170
 171 (defun riece-epg-add-encrypted-button (start end)
 172   (if (and (get 'riece-button 'riece-addon-enabled)
 173            (get 'riece-epg 'riece-addon-enabled))
 174       (riece-scan-property-region
 175        'riece-epg-encryption-target
 176        start end
 177        (lambda (start end)
 178          (let ((inhibit-read-only t)
 179                buffer-read-only)
 180            (widget-convert-button
 181             'link start end
 182             :help-echo "Click to decrypt"
 183             :notify #'riece-epg-encrypted-button-notify
 184             (get-text-property start 'riece-epg-encryption-target)))))))
 185
 186 (defun riece-epg-encrypted-button-notify (widget &rest ignore)
 187   (let* ((from (marker-position (widget-get widget :from)))
 188          (to (marker-position (widget-get widget :to)))
 189          (target (widget-get widget :value))
 190          (cipher (buffer-substring from to))
 191          (inhibit-read-only t)
 192          buffer-read-only
 193          plain)
 194     (when (string-match "\\`\\[encrypted:\\(.*\\)]" cipher)
 195       (setq plain (riece-epg-decrypt-string-for-identity
 196                    (epg-make-context) (match-string 1 cipher) target))
 197       (widget-delete widget)
 198       (delete-region from to)
 199       (save-excursion
 200         (goto-char from)
 201         (insert "[decrypted:" plain "]")))))
 202
 203 (defun riece-epg-requires ()
 204   (if (memq 'riece-button riece-addons)
 205       '(riece-button)))
 206
 207 (defun riece-epg-insinuate ()
 208   (add-hook 'riece-message-filter-functions 'riece-epg-message-filter)
 209   (add-hook 'riece-after-insert-functions 'riece-epg-add-encrypted-button))
 210
 211 (defun riece-epg-uninstall ()
 212   (remove-hook 'riece-message-filter-functions 'riece-epg-message-filter)
 213   (remove-hook 'riece-after-insert-functions 'riece-epg-add-encrypted-button))
 214
 215 (defvar riece-command-mode-map)
 216 (defun riece-epg-enable ()
 217   (define-key riece-command-mode-map
 218     "\C-ce" 'riece-command-enter-encrypted-message)
 219   (define-key riece-command-mode-map
 220     "\C-c\C-ec" 'riece-command-set-passphrase))
 221
 222 (defun riece-epg-disable ()
 223   (define-key riece-command-mode-map
 224     "\C-ce" nil)
 225   (define-key riece-command-mode-map
 226     "\C-c\C-ec" nil))
 227
 228 (provide 'riece-epg)
 229
 230 ;;; riece-epg.el ends here