* qmtp.el (qmtp-timeout): New user option.
[elisp/flim.git] / qmtp.el
1 ;;; qmtp.el --- basic functions to send mail with QMTP server
2
3 ;; Copyright (C) 2000 Daiki Ueno
4
5 ;; Author: Daiki Ueno <ueno@unixuser.org>
6 ;; Keywords: QMTP, qmail
7
8 ;; This file is part of FLIM (Faithful Library about Internet Message).
9
10 ;; This program is free software; you can redistribute it and/or
11 ;; modify it under the terms of the GNU General Public License as
12 ;; published by the Free Software Foundation; either version 2, or (at
13 ;; your option) any later version.
14
15 ;; This program is distributed in the hope that it will be useful, but
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
18 ;; General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with this program; see the file COPYING.  If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
24
25
26 ;;; Commentary:
27 ;; 
28
29 ;;; Code:
30
31 (require 'poem)
32 (require 'pcustom)
33
34 (defgroup qmtp nil
35   "QMTP protocol for sending mail."
36   :group 'mail)
37
38 (defcustom qmtp-default-server nil
39   "Specify default QMTP server."
40   :type '(choice (const nil) string)
41   :group 'qmtp)
42
43 (defvar qmtp-server qmtp-default-server
44   "The name of the host running QMTP server.
45 It can also be a function
46 called from `qmtp-via-qmtp' with arguments SENDER and RECIPIENTS.")
47
48 (defcustom qmtp-service "qmtp"
49   "QMTP service port number.  \"qmtp\" or 209."
50   :type '(choice (integer :tag "209" 209)
51                  (string :tag "qmtp" "qmtp"))
52   :group 'qmtp)
53
54 (defcustom qmtp-timeout 30
55   "Timeout for each QMTP session."
56   :type 'integer
57   :group 'qmtp)
58
59 (defvar qmtp-open-connection-function (function open-network-stream))
60
61 (defvar qmtp-error-response-alist
62   '((?Z "Temporary failure")
63     (?D "Permanent failure")))
64
65 (defvar qmtp-read-point nil)
66
67 (defun qmtp-encode-netstring-string (string)
68   (format "%d:%s," (length string) string))
69
70 (defun qmtp-send-package (process sender recipients buffer)
71   (with-temp-buffer
72     (buffer-disable-undo)
73     (erase-buffer)
74     (set-buffer-multibyte nil)
75     (insert
76      (format "%d:\n"
77              (with-current-buffer buffer
78                (1+ (point-max));; for the "\n"
79                )))
80     (insert-buffer-substring buffer)
81     (insert
82      "\n,"
83      (qmtp-encode-netstring-string sender)
84      (qmtp-encode-netstring-string
85       (mapconcat #'qmtp-encode-netstring-string
86                  recipients "")))
87     (process-send-region process (point-min)(point-max)))
88   (goto-char qmtp-read-point)
89   (while recipients
90     (while (and (memq (process-status process) '(open run))
91                 (not (re-search-forward "^[0-9]+:" nil 'noerror)))
92       (or (accept-process-output process qmtp-timeout)
93           (error "timeout expired: %d" qmtp-timeout))
94       (goto-char qmtp-read-point))
95     (let ((response (char-after (match-end 0))))
96       (if (not (eq response ?K))
97           (error (nth 1 (assq response qmtp-error-response-alist))))
98       (setq recipients (cdr recipients))
99       (beginning-of-line 2)
100       (setq qmtp-read-point (point)))))
101
102 (defun qmtp-via-qmtp (sender recipients buffer)
103   (save-excursion
104     (set-buffer
105      (get-buffer-create
106       (format "*trace of QMTP session to %s*" qmtp-server)))
107     (buffer-disable-undo)
108     (erase-buffer)
109     (make-local-variable 'qmtp-read-point)
110     (setq qmtp-read-point (point-min))
111     (let (process)
112       (unwind-protect
113           (progn
114             (as-binary-process
115              (setq process
116                    (funcall qmtp-open-connection-function
117                             "QMTP" (current-buffer) qmtp-server qmtp-service)))
118             (condition-case nil
119                 (progn
120                   (qmtp-send-package process sender recipients buffer)
121                   t)
122               (error)))
123         (when (and process
124                    (memq (process-status process) '(open run)))
125           ;; QUIT
126           (process-send-eof process)
127           (delete-process process))))))
128
129 (provide 'qmtp)
130
131 ;;; qmtp.el ends here