jabber-ft-server.el

   1 ;; jabber-ft-server.el - handle incoming file transfers, by JEP-0096
   2
   3 ;; Copyright (C) 2003, 2004, 2007 - Magnus Henoch - mange@freemail.hu
   4 ;; Copyright (C) 2002, 2003, 2004 - tom berger - object@intelectronica.net
   5
   6 ;; This file is a part of jabber.el.
   7
   8 ;; This program is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation; either version 2 of the License, or
  11 ;; (at your option) any later version.
  12
  13 ;; This program is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with this program; if not, write to the Free Software
  20 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  21
  22 (require 'jabber-si-server)
  23 (require 'jabber-util)
  24
  25 (defvar jabber-ft-sessions nil
  26   "Alist, where keys are (sid jid), and values are buffers of the files.")
  27
  28 (defvar jabber-ft-size nil
  29   "Size of the file that is being downloaded")
  30
  31 (defvar jabber-ft-md5-hash nil
  32   "MD5 hash of the file that is being downloaded")
  33
  34 (add-to-list 'jabber-advertised-features "http://jabber.org/protocol/si/profile/file-transfer")
  35
  36 (add-to-list 'jabber-si-profiles
  37              (list "http://jabber.org/protocol/si/profile/file-transfer"
  38                    'jabber-ft-accept
  39                    'jabber-ft-server-connected))
  40
  41 (defun jabber-ft-accept (jc xml-data)
  42   "Receive IQ stanza containing file transfer request, ask user"
  43   (let* ((from (jabber-xml-get-attribute xml-data 'from))
  44          (query (jabber-iq-query xml-data))
  45          (si-id (jabber-xml-get-attribute query 'id))
  46          ;; TODO: check namespace
  47          (file (car (jabber-xml-get-children query 'file)))
  48          (name (jabber-xml-get-attribute file 'name))
  49          (size (jabber-xml-get-attribute file 'size))
  50          (date (jabber-xml-get-attribute file 'date))
  51          (md5-hash (jabber-xml-get-attribute file 'hash))
  52          (desc (car (jabber-xml-node-children
  53                      (car (jabber-xml-get-children file 'desc)))))
  54          (range (car (jabber-xml-get-children file 'range))))
  55     (unless (and name size)
  56       ;; both name and size must be present
  57       (jabber-signal-error "modify" 'bad-request))
  58
  59     (let ((question (format
  60                      "%s is sending you the file %s (%s bytes).%s  Accept? "
  61                      (jabber-jid-displayname from)
  62                      name
  63                      size
  64                      (if (not (zerop (length desc)))
  65                          (concat "  Description: '" desc "'")
  66                        ""))))
  67       (unless (yes-or-no-p question)
  68         (jabber-signal-error "cancel" 'forbidden)))
  69
  70     ;; default is to save with given name, in current directory.
  71     ;; maybe that's bad; maybe should be customizable.
  72     (let* ((file-name (read-file-name "Download to: " nil nil nil name))
  73            (buffer (create-file-buffer file-name)))
  74       (message "Starting download of %s..." (file-name-nondirectory file-name))
  75       (with-current-buffer buffer
  76         (kill-all-local-variables)
  77         (setq buffer-file-coding-system 'binary)
  78         ;; For Emacs, switch buffer to unibyte _before_ anything goes into it,
  79         ;; otherwise binary files are corrupted.  For XEmacs, it isn't needed,
  80         ;; and it also doesn't have set-buffer-multibyte.
  81         (if (fboundp 'set-buffer-multibyte)
  82             (set-buffer-multibyte nil))
  83         (set-visited-file-name file-name t)
  84         (set (make-local-variable 'jabber-ft-size)
  85              (string-to-number size))
  86         (set (make-local-variable 'jabber-ft-md5-hash)
  87              md5-hash))
  88       (add-to-list 'jabber-ft-sessions
  89                    (cons (list si-id from) buffer)))
  90
  91     ;; to support range, return something sensible here
  92     nil))
  93
  94 (defun jabber-ft-server-connected (jc jid sid send-data-function)
  95   ;; We don't really care about the send-data-function.  But if it's
  96   ;; a string, it means that we have no connection.
  97   (if (stringp send-data-function)
  98       (message "File receiving failed: %s" send-data-function)
  99     ;; On success, we just return our data receiving function.
 100     'jabber-ft-data))
 101
 102 (defun jabber-ft-data (jc jid sid data)
 103   "Receive chunk of transferred file."
 104   (let ((buffer (cdr (assoc (list sid jid) jabber-ft-sessions))))
 105     (with-current-buffer buffer
 106       ;; If data is nil, there is no more data.
 107       ;; But maybe the remote entity doesn't close the stream -
 108       ;; then we have to keep track of file size to know when to stop.
 109       ;; Return value is whether to keep connection open.
 110       (when data
 111         (insert data))
 112       (if (and data (< (buffer-size) jabber-ft-size))
 113           t
 114         (basic-save-buffer)
 115         (if (and jabber-ft-md5-hash
 116                  (let ((file-hash (jabber-ft-get-md5 buffer-file-name)))
 117                    (and file-hash
 118                         (not (string= file-hash jabber-ft-md5-hash)))))
 119             ;; hash mismatch!
 120             (progn
 121               (message "%s downloaded - CHECKSUM MISMATCH!"
 122                        (file-name-nondirectory buffer-file-name))
 123               (sleep-for 5))
 124           ;; all is fine
 125           (message "%s downloaded" (file-name-nondirectory buffer-file-name)))
 126         (kill-buffer buffer)
 127         nil))))
 128
 129 (provide 'jabber-ft-server)
 130
 131 ;;; arch-tag: 334adcff-6210-496e-8382-8f49ae0248a1