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 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         entry)
  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 "[decrypted:" string "]") nil t))
 112     (let ((next-line-add-newlines t))
 113       (next-line 1))))
 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               entry)
 159           (epg-context-set-passphrase-callback
 160            context
 161            (cons #'riece-epg-passphrase-callback-function-for-decrypt
 162                  riece-current-channel))
 163           (condition-case error
 164               (progn
 165                 (riece-message-set-text
 166                  message
 167                  (format "[decrypted:%s]"
 168                          (riece-epg-decrypt-string-for-identity
 169                           context string (riece-message-target message)))))
 170             (error
 171              (riece-put-text-property-nonsticky
 172               0 (length (riece-message-text message))
 173               'riece-epg-encryption-target (riece-message-target message)
 174               (riece-message-text message))
 175              (message "%s" (cdr error)))))))
 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