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