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