;;; liece-dcc.el --- DCC handlers and commands.
;; Copyright (C) 1998-2000 Daiki Ueno

;; Author: Daiki Ueno <ueno@unixuser.org>
;; Created: 1998-09-28
;; Revised: 1998-11-25
;; Keywords: IRC, liece, DCC

;; This file is part of Liece.

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	 See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.


;;; Commentary:
;; 

;;; Code:

(eval-when-compile
  (require 'liece-intl)
  (require 'liece-inlines)
  (require 'liece-channel))

(eval-when-compile (require 'queue-m))

(require 'liece-coding)
(require 'liece-misc)
(require 'liece-minibuf)

(defvar liece-dcc-requests (queue-create))
(defvar liece-dcc-receive-direct t)
(defvar liece-dcc-process-alist nil)

(defconst liece-dcc-acceptable-messages '("SEND" "CHAT"))

(defstruct liece-dcc-object type from host port file size)

(defun liece-dcc-enqueue-request (type &rest args)
  (let ((request (apply #'make-liece-dcc-object :type type args)))
    (inline (queue-enqueue liece-dcc-requests request))))

(defun liece-dcc-dequeue-request (&optional type)
  (when (or (not type)
	    (eq (liece-dcc-object-type
		 (queue-first liece-dcc-requests))
		type))
    (inline (queue-dequeue liece-dcc-requests))))

(defmacro liece-dcc-add-to-process-alist (process type &rest args)
  `(push (cons (process-name ,process)
	       (make-liece-dcc-object :type ,type ,@args))
	 liece-dcc-process-alist))

(defmacro liece-dcc-get-process-object (process)
  `(cdr (assoc (process-name ,process) liece-dcc-process-alist)))

(defmacro liece-dcc-message (&rest msg)
  `(message "DCC %s" (format ,@msg)))

(defun* liece-ctcp-dcc-message (from chnl rest)
  (cond
   ((string-match "^SEND +" rest)
    (multiple-value-bind (filename host port size)
	(split-string (substring rest (match-end 0)))
      (setq filename (file-name-nondirectory filename))
      (liece-insert-dcc
       (append liece-O-buffer liece-D-buffer)
       (format (_ "SEND request from %s: %s (%s bytes)\n")
	       from filename size))
      (liece-dcc-enqueue-request
       'send :from from :host host :port port :file filename :size size)
      (when liece-dcc-receive-direct
	(liece-insert-dcc
	 (append liece-O-buffer liece-D-buffer)
	 (format (_ "SEND applied autoreceive: %s (%s bytes)\n")
		 filename size))
	(liece-command-dcc-receive))))
   ((string-match "^CHAT [^ ]+ +" rest)
    (multiple-value-bind (host port)
	(split-string (substring rest (match-end 0)))
      (liece-dcc-enqueue-request 'chat :from from :host host :port port)
      (liece-insert-dcc
       (append liece-O-buffer liece-D-buffer)
       (concat "CHAT request from " from "\n"))))))

(defun liece-command-dcc-send (filename towhom)
  "Send file to user."
  (interactive
   (list (expand-file-name
	  (read-file-name
	   (_ "File to send: ")
	   default-directory nil))
	 (liece-minibuffer-completing-read
	  (_ "To whom: ")
	  (append liece-nick-alist liece-channel-alist)
	  nil nil nil nil liece-privmsg-partner)))

  (setq liece-privmsg-partner towhom)
  (let (process)
    (setq process (start-process
		   liece-dcc-program nil liece-dcc-program
		   "send" (int-to-string liece-dcc-port) filename))
    (set-process-filter process #'liece-dcc-send-filter)
    (set-process-sentinel process #'liece-dcc-sentinel))
  (or (zerop liece-dcc-port)
      (incf liece-dcc-port)))

(defun liece-dcc-sentinel (process output)
  (let* ((object (liece-dcc-get-process-object process))
	 (type (liece-dcc-object-type object)))
    (if (null object)
        (delete-process process)
      (if (string-match "^finished" output)
	  (cond
	   ((eq type 'send)
	    (liece-dcc-message (_ "Sent file to %s: %s (%s bytes)")
			       (liece-dcc-object-from object)
			       (liece-dcc-object-file object)
			       (liece-dcc-object-size object)))
	   ((eq type 'receive)
	    (liece-dcc-message (_ "Received file from %s: %s (%s bytes)")
			       (liece-dcc-object-from object)
			       (liece-dcc-object-file object)
			       (liece-dcc-object-size object)))
	   ((eq type 'chat)
	    (liece-dcc-message (_ "Chat connection with %s finished")
			       (liece-dcc-object-from object))))
	(liece-dcc-message
	 (_ "%s error (%s %s %s) is %s\n")
	 (capitalize (downcase (prin1-to-string
				(liece-dcc-object-type object))))
	 (or (liece-dcc-object-file object) "")
	 (cond ((eq type 'send) "to")
	       ((eq type 'receive) "from")
	       ((eq type 'chat) "with"))
	 (liece-dcc-object-from object)
	 (substring output 0 (1- (length output))))))))

(defun liece-dcc-send-filter (process output)
  (if (string-match "DCC send +" output)
      (multiple-value-bind (filename port host size)
	  (split-string (substring output (match-end 0)))
	(setq filename (file-name-nondirectory filename))
	(liece-send "PRIVMSG %s :\001DCC SEND %s %s %s %s\001"
		    liece-privmsg-partner filename host port size)
	(liece-dcc-message (_ "Sending file to %s: %s (%s bytes)")
			   liece-privmsg-partner filename size)
	(liece-dcc-add-to-process-alist process 'send
					:host host
					:port port
					:from liece-privmsg-partner
					:file filename
					:size size))
    (liece-dcc-message (_ "send error to %s: %s")
		       liece-privmsg-partner
		       (substring output 0 (1- (length output))))))

(defmacro liece-dcc-prepare-directory ()
  '(or (file-directory-p (expand-file-name liece-dcc-directory))
       (and (y-or-n-p (_ "DCC directory does not exist. Create it? "))
	    (make-directory (expand-file-name liece-dcc-directory)))))

(defun liece-command-dcc-receive (&optional number)
  "Receive next file from list."
  (interactive "P")
  (let ((object (liece-dcc-dequeue-request 'send)))
    (if (not object)
	(liece-message (_ "DCC No send request has been arrived."))
      (liece-dcc-message (_ "Getting file from %s: %s (%s bytes)")
			  (liece-dcc-object-from object)
			  (liece-dcc-object-file object)
			  (liece-dcc-object-size object))
      (liece-dcc-prepare-directory)
      (let ((file
	     (expand-file-name
	      (liece-dcc-object-file object)
	      liece-dcc-directory))
	    process)
	(setq process
	      (start-process
	       liece-dcc-program nil liece-dcc-program
	       "receive"
	       (liece-dcc-object-host object)
	       (liece-dcc-object-port object)
	       (liece-dcc-object-size object)
	       (expand-file-name
		(liece-dcc-object-file object)
		liece-dcc-directory)))
	(set-process-filter process #'liece-dcc-receive-filter)
	(set-process-sentinel process  #'liece-dcc-sentinel)
	(liece-dcc-add-to-process-alist
	 process 'receive
	 :from (liece-dcc-object-from object)
	 :host (liece-dcc-object-host object)
	 :port (liece-dcc-object-port object)
	 :file file
	 :size (liece-dcc-object-size object))))))

(defun liece-dcc-receive-filter (process output)
  (liece-dcc-message "%s" (substring output 0 (1- (length output)))))

(defun liece-command-dcc-chat-listen (towhom)
  (interactive
   (list (liece-minibuffer-completing-read
	  (_ "With whom: ")
	  (append liece-nick-alist liece-channel-alist)
	  nil nil nil nil liece-privmsg-partner)))
  (setq liece-privmsg-partner towhom)
  (let (process)
    (as-binary-process
     (setq process
	   (start-process
	    liece-dcc-program nil
	    liece-dcc-program "chat" "listen"
	    (int-to-string liece-dcc-port)))
     (set-process-buffer
      process
      (liece-get-buffer-create (format " DCC:%s" (process-id process))))
     (set-process-filter process 'liece-dcc-chat-listen-filter)
     (set-process-sentinel process 'liece-dcc-sentinel)))
  (unless (zerop liece-dcc-port)
    (setq liece-dcc-port (1+ liece-dcc-port))))

(defun liece-dcc-chat-listen-filter (process output)
  (cond
   ((string-match "DCC chat +" output)
    (multiple-value-bind (host port)
	(split-string (substring output (match-end 0)))
      (liece-send "PRIVMSG %s :\001DCC CHAT chat %s %s\001"
		  liece-privmsg-partner host port)
      (liece-dcc-message (_ "Ringing user %s")
			 liece-privmsg-partner)
      (liece-dcc-add-to-process-alist
       process 'chat :from liece-privmsg-partner)))
   ((string-match "^DCC chat established" output)
    (set-process-filter process 'liece-dcc-chat-filter)
    (let* ((object (liece-dcc-get-process-object process))
	   (nick (liece-dcc-object-from object)))
      (setq nick (liece-channel-prepare-representation nick 'dcc))
      (liece-channel-prepare-partner nick)
      (liece-dcc-message (_ "Chat connection established with: %s")
			 nick))
    (message ""))
   (t
    (liece-dcc-message (_ "listen error to %s: %s")
		       liece-privmsg-partner
		       (substring output 0 (1- (length output)))))))

(defun liece-command-dcc-chat-connect (&optional number)
  (interactive "P")
  (let* ((object (liece-dcc-dequeue-request 'chat))
	 (nick (liece-dcc-object-from object))
	 process)
    (if (not object)
	(liece-message (_ "DCC No chat request has been arrived."))
      (liece-dcc-message (_ "Connecting to: %s") nick)
      (setq liece-privmsg-partner nick)
      (as-binary-process
       (setq process
	     (start-process liece-dcc-program nil
			    liece-dcc-program "chat" "connect"
			    (liece-dcc-object-host object)
			    (liece-dcc-object-port object)))
       (set-process-buffer
	process
	(liece-get-buffer-create
	 (format " DCC:%s" (process-id process))))
       (set-process-filter process #'liece-dcc-chat-connect-filter)
       (set-process-sentinel process #'liece-dcc-sentinel)
       (liece-dcc-add-to-process-alist
	process 'chat :from liece-privmsg-partner)))))

(defun liece-dcc-chat-connect-filter (process output)
  (if (string-match "^DCC chat established" output)
      (let* ((object (liece-dcc-get-process-object process))
	     (nick (liece-dcc-object-from object)))
	(set-process-filter process #'liece-dcc-chat-filter)
	(setq nick (liece-channel-prepare-representation nick 'dcc))
	(liece-channel-prepare-partner nick)
	(liece-dcc-message (_ "Chat connection established with: %s")
			   nick)
	(message ""))
    (liece-dcc-message
     (_ "connect error to %s: %s")
     liece-privmsg-partner
     (substring output 0 (1- (length output))))))

(defun liece-dcc-chat-filter (process output)
  (save-match-data
    (with-current-buffer (process-buffer process)
      (let* ((object (liece-dcc-get-process-object process))
	     (nick (liece-channel-prepare-representation
		    (liece-dcc-object-from object) 'dcc)))
	(goto-char (point-max))
	(insert output)
	(goto-char (point-min))
	(while (search-forward "\n\n" (point-max) t)
	  (delete-char -1))
	(goto-char (point-min))
	(when (string-match "\n" output)
	  (let (st nd line)
	    (while (looking-at ".*\n")
	      (setq st (match-beginning 0) nd (match-end 0)
		    line (liece-coding-decode-charset-string
			  (buffer-substring st (1- nd))))
	      (delete-region st nd)
	      (let ((liece-message-target (liece-current-nickname))
		    (liece-message-speaker nick))
		(liece-display-message line)))))))))

(defun liece-dcc-chat-nick-to-process (nick)
  "Convert NICK to process symbol."
  (let ((alist liece-dcc-process-alist)
	pair)
    (catch 'found
      (while alist
	(setq pair (pop alist))
	(if (and (eq 'chat (cadr pair))
		 (liece-nick-equal nick (caddr pair)))
	    (throw 'found (car pair))))
      nil)))

(defun liece-dcc-chat-send (nick message)
  "Send MSG string to NICK via DCC chat."
  (let ((process (liece-dcc-chat-nick-to-process nick)))
    (if (not process)
	(liece-message (_ "DCC chat has not been started."))
      (with-current-buffer liece-command-buffer
	(setq message (liece-coding-encode-charset-string message)
	      message (if (string-match "\r$" message) message
			(concat message "\r\n")))
	(process-send-string process message)))))

(defun liece-command-dcc-accept ()
  "Dispatch one DCC request."
  (interactive)
  (let* ((object (queue-first liece-dcc-requests))
	 (type (liece-dcc-object-type object)))
    (cond ((eq type 'send)
	   (liece-command-dcc-receive))
	  ((eq type 'chat)
	   (liece-command-dcc-chat-connect))
	  (t
	   (liece-message
	    (_ "DCC No request has been arrived."))))))

(defun liece-command-dcc-list ()
  "List files in receive queue."
  (interactive)
  (if (queue-empty liece-dcc-requests)
      (liece-dcc-message (_ "No DCC request here"))
    (let ((i 0) (objects (queue-all liece-dcc-requests)) type)
      (dolist (object objects)
	(setq type (liece-dcc-object-type object))
	(cond ((eq type 'send)
	       (liece-dcc-message
		(_ "(%d) %s request %s: %s (%s bytes)")
		i (upcase (symbol-name type))
		(liece-dcc-object-from object)
		(liece-dcc-object-file object)
		(liece-dcc-object-size object)))
	      ((eq type 'chat)
	       (liece-dcc-message
		(_ "(%d) %s request from %s")
		i (upcase (symbol-name type))
		(liece-dcc-object-from object))))
	(incf i)))))

(defun liece-dcc-compare-hostnames (h1 h2)
  "Compare two internet domain hostnames. Return true iff they resolve to the
same IP-address."
  (or
   (string-equal-ignore-case h1 h2)
   (if liece-dcc-program
       (let ((pob (liece-get-buffer-create "*IRC DCC resolve*"))
	     (output) (domatch nil))
	 (save-excursion
	   (call-process liece-dcc-program nil pob nil "resolve" h1 h2)
	   (set-buffer pob)
	   (goto-char (point-min))
	   (setq output (buffer-substring (point-min) (point-max)))
	   (if (string-match "\\([^ ]+\\)\n\\([^ ]+\\)\n" output)
	       (if (string= (match-string 1 output)
			    (match-string 2 output))
		   (setq domatch t))))
	 (kill-buffer pob)
	 domatch)
     (string-equal-ignore-case h1 h2))))

(provide 'liece-dcc)

;;; liece-dcc.el ends here