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 (context 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 context
  58                                                                  key-id nil))
  59               (setcdr entry (copy-sequence passphrase))
  60               passphrase)))
  61     (epg-passphrase-callback-function context key-id nil)))
  62
  63 (defun riece-epg-passphrase-callback-function-for-decrypt (context key-id
  64                                                                    identity)
  65   (if (eq key-id 'SYM)
  66       (let ((entry (riece-identity-assoc identity riece-epg-passphrase-alist))
  67             passphrase)
  68         (if (cdr entry)
  69             (copy-sequence (cdr entry))
  70           (epg-cancel context)))
  71     (epg-passphrase-callback-function context key-id nil)))
  72
  73 (defun riece-epg-funcall-clear-passphrase (identity function &rest args)
  74   (condition-case error
  75       (apply function args)
  76     (error
  77      (let ((entry (riece-identity-assoc identity riece-epg-passphrase-alist)))
  78        (if entry
  79            (setq riece-epg-passphrase-alist
  80                  (delq entry riece-epg-passphrase-alist))))
  81      (signal (car error) (cdr error)))))
  82
  83 (defun riece-command-enter-encrypted-message ()
  84   "Encrypt the current line send send it to the current channel."
  85   (interactive)
  86   (let ((context (epg-make-context))
  87         (string (buffer-substring
  88                  (riece-line-beginning-position)
  89                  (riece-line-end-position)))
  90         entry)
  91     (riece-with-server-buffer (riece-identity-server riece-current-channel)
  92       (setq string (riece-encode-coding-string-for-identity
  93                     string
  94                     riece-current-channel)))
  95     (epg-context-set-passphrase-callback
  96      context
  97      (cons #'riece-epg-passphrase-callback-function
  98            riece-current-channel))
  99     (setq string (riece-epg-funcall-clear-passphrase riece-current-channel
 100                                                      #'epg-encrypt-string
 101                                                      context string nil))
 102     (riece-command-send-message
 103      (concat "[encrypted:" (base64-encode-string string t) "]")
 104      nil)
 105     (let ((next-line-add-newlines t))
 106       (next-line 1))))
 107
 108 (defun riece-command-set-passphrase (identity passphrase)
 109   "Set PASSPHRASE associated with IDENTITY."
 110   (interactive
 111    (let ((identity
 112           (riece-completing-read-identity
 113            "Channel/user: "
 114            riece-current-channels nil t nil nil
 115            (riece-format-identity riece-current-channel))))
 116      (list identity
 117            (read-passwd (format "Passphrase for %s: "
 118                                 (riece-format-identity identity))))))
 119   (let ((entry (riece-identity-assoc identity riece-epg-passphrase-alist)))
 120     (if (equal passphrase "")
 121         (if entry
 122             (setq riece-epg-passphrase-alist
 123                   (delq entry riece-epg-passphrase-alist)))
 124       (if entry
 125           (setcdr entry passphrase)
 126         (setq riece-epg-passphrase-alist
 127               (cons (cons identity passphrase)
 128                     riece-epg-passphrase-alist))))))
 129
 130 (defun riece-epg-decrypt-string-for-identity (context cipher target)
 131   (let ((coding-system
 132          (or (riece-coding-system-for-identity target)
 133              riece-default-coding-system)))
 134     (riece-with-server-buffer (riece-identity-server target)
 135       (decode-coding-string
 136        (riece-epg-funcall-clear-passphrase
 137         target
 138         #'epg-decrypt-string
 139         context
 140         (base64-decode-string cipher))
 141        (if (consp coding-system)
 142            (car coding-system)
 143          coding-system)))))
 144
 145 (defun riece-epg-message-filter (message)
 146   (if (get 'riece-epg 'riece-addon-enabled)
 147       (when (string-match "\\`\\[encrypted:\\(.*\\)]"
 148                           (riece-message-text message))
 149         (let ((context (epg-make-context))
 150               (string (match-string 1 (riece-message-text message)))
 151               entry)
 152           (epg-context-set-passphrase-callback
 153            context
 154            (cons #'riece-epg-passphrase-callback-function-for-decrypt
 155                  riece-current-channel))
 156           (condition-case error
 157               (progn
 158                 (riece-message-set-text
 159                  message
 160                  (concat
 161                   "[decrypted:"
 162                   (riece-epg-decrypt-string-for-identity
 163                    context string (riece-message-target message))
 164                   "]")))
 165             (error
 166              (riece-put-text-property-nonsticky
 167               0 (length (riece-message-text message))
 168               'riece-epg-encryption-target (riece-message-target message)
 169               (riece-message-text message))
 170              (message "%s" (cdr error)))))))
 171   message)
 172
 173 (defun riece-epg-add-encrypted-button (start end)
 174   (if (and (get 'riece-button 'riece-addon-enabled)
 175            (get 'riece-epg 'riece-addon-enabled))
 176       (riece-scan-property-region
 177        'riece-epg-encryption-target
 178        start end
 179        (lambda (start end)
 180          (let ((inhibit-read-only t)
 181                buffer-read-only)
 182            (widget-convert-button
 183             'link start end
 184             :help-echo "Click to decrypt"
 185             :notify #'riece-epg-encrypted-button-notify
 186             (get-text-property start 'riece-epg-encryption-target)))))))
 187
 188 (defun riece-epg-encrypted-button-notify (widget &rest ignore)
 189   (let* ((from (marker-position (widget-get widget :from)))
 190          (to (marker-position (widget-get widget :to)))
 191          (target (widget-get widget :value))
 192          (cipher (buffer-substring from to))
 193          (inhibit-read-only t)
 194          buffer-read-only
 195          plain)
 196     (when (string-match "\\`\\[encrypted:\\(.*\\)]" cipher)
 197       (setq plain (riece-epg-decrypt-string-for-identity
 198                    (epg-make-context) (match-string 1 cipher) target))
 199       (widget-delete widget)
 200       (delete-region from to)
 201       (save-excursion
 202         (goto-char from)
 203         (insert "[decrypted:" plain "]")))))
 204
 205 (defun riece-epg-requires ()
 206   (if (memq 'riece-button riece-addons)
 207       '(riece-button)))
 208
 209 (defun riece-epg-insinuate ()
 210   (add-hook 'riece-message-filter-functions 'riece-epg-message-filter)
 211   (add-hook 'riece-after-insert-functions 'riece-epg-add-encrypted-button))
 212
 213 (defun riece-epg-uninstall ()
 214   (remove-hook 'riece-message-filter-functions 'riece-epg-message-filter)
 215   (remove-hook 'riece-after-insert-functions 'riece-epg-add-encrypted-button))
 216
 217 (defvar riece-command-mode-map)
 218 (defun riece-epg-enable ()
 219   (define-key riece-command-mode-map
 220     "\C-ce" 'riece-command-enter-encrypted-message)
 221   (define-key riece-command-mode-map
 222     "\C-c\C-ec" 'riece-command-set-passphrase))
 223
 224 (defun riece-epg-disable ()
 225   (define-key riece-command-mode-map
 226     "\C-ce" nil)
 227   (define-key riece-command-mode-map
 228     "\C-c\C-ec" nil))
 229
 230 (provide 'riece-epg)
 231
 232 ;;; riece-epg.el ends here