1;;; url-gw.el --- Gateway munging for URL loading
2
3;; Copyright (C) 1997, 1998, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
4
5;; Author: Bill Perry <wmperry@gnu.org>
6;; Keywords: comm, data, processes
7
8;; This file is part of GNU Emacs.
9
10;; GNU Emacs is free software; you can redistribute it and/or modify
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation; either version 2, or (at your option)
13;; any later version.
14
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
21;; along with GNU Emacs; see the file COPYING.  If not, write to the
22;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
23;; Boston, MA 02110-1301, USA.
24
25;;; Code:
26
27(eval-when-compile (require 'cl))
28(require 'url-vars)
29
30;; Fixme: support SSH explicitly or via a url-gateway-rlogin-program?
31
32(autoload 'socks-open-network-stream "socks")
33(autoload 'open-ssl-stream "ssl")
34(autoload 'open-tls-stream "tls")
35
36(defgroup url-gateway nil
37  "URL gateway variables."
38  :group 'url)
39
40(defcustom url-gateway-local-host-regexp nil
41  "*A regular expression specifying local hostnames/machines."
42  :type '(choice (const nil) regexp)
43  :group 'url-gateway)
44
45(defcustom url-gateway-prompt-pattern
46  "^[^#$%>;]*[#$%>;] *" ;; "bash\\|\$ *\r?$\\|> *\r?"
47  "*A regular expression matching a shell prompt."
48  :type 'regexp
49  :group 'url-gateway)
50
51(defcustom url-gateway-rlogin-host nil
52  "*What hostname to actually rlog into before doing a telnet."
53  :type '(choice (const nil) string)
54  :group 'url-gateway)
55
56(defcustom url-gateway-rlogin-user-name nil
57  "*Username to log into the remote machine with when using rlogin."
58  :type '(choice (const nil) string)
59  :group 'url-gateway)
60
61(defcustom url-gateway-rlogin-parameters '("telnet" "-8")
62  "*Parameters to `url-open-rlogin'.
63This list will be used as the parameter list given to rsh."
64  :type '(repeat string)
65  :group 'url-gateway)
66
67(defcustom url-gateway-telnet-host nil
68  "*What hostname to actually login to before doing a telnet."
69  :type '(choice (const nil) string)
70  :group 'url-gateway)
71
72(defcustom url-gateway-telnet-parameters '("exec" "telnet" "-8")
73  "*Parameters to `url-open-telnet'.
74This list will be executed as a command after logging in via telnet."
75  :type '(repeat string)
76  :group 'url-gateway)
77
78(defcustom url-gateway-telnet-login-prompt "^\r*.?login:"
79  "*Prompt that tells us we should send our username when loggin in w/telnet."
80  :type 'regexp
81  :group 'url-gateway)
82
83(defcustom url-gateway-telnet-password-prompt "^\r*.?password:"
84  "*Prompt that tells us we should send our password when loggin in w/telnet."
85  :type 'regexp
86  :group 'url-gateway)
87
88(defcustom url-gateway-telnet-user-name nil
89  "User name to log in via telnet with."
90  :type '(choice (const nil) string)
91  :group 'url-gateway)
92
93(defcustom url-gateway-telnet-password nil
94  "Password to use to log in via telnet with."
95  :type '(choice (const nil) string)
96  :group 'url-gateway)
97
98(defcustom url-gateway-broken-resolution nil
99  "*Whether to use nslookup to resolve hostnames.
100This should be used when your version of Emacs cannot correctly use DNS,
101but your machine can.  This usually happens if you are running a statically
102linked Emacs under SunOS 4.x"
103  :type 'boolean
104  :group 'url-gateway)
105
106(defcustom url-gateway-nslookup-program "nslookup"
107  "*If non-nil then a string naming nslookup program."
108  :type '(choice (const :tag "None" :value nil) string)
109  :group 'url-gateway)
110
111;; Stolen from ange-ftp
112;;;###autoload
113(defun url-gateway-nslookup-host (host)
114  "Attempt to resolve the given HOST using nslookup if possible."
115  (interactive "sHost:  ")
116  (if url-gateway-nslookup-program
117      (let ((proc (start-process " *nslookup*" " *nslookup*"
118				 url-gateway-nslookup-program host))
119	    (res host))
120	(set-process-query-on-exit-flag proc nil)
121	(with-current-buffer (process-buffer proc)
122	  (while (memq (process-status proc) '(run open))
123	    (accept-process-output proc))
124	  (goto-char (point-min))
125	  (if (re-search-forward "Name:.*\nAddress: *\\(.*\\)$" nil t)
126	      (setq res (buffer-substring (match-beginning 1)
127					  (match-end 1))))
128	  (kill-buffer (current-buffer)))
129	res)
130    host))
131
132;; Stolen from red gnus nntp.el
133(defun url-wait-for-string (regexp proc)
134  "Wait until string matching REGEXP arrives in process PROC's buffer."
135  (let ((buf (current-buffer)))
136    (goto-char (point-min))
137    (while (not (re-search-forward regexp nil t))
138      (accept-process-output proc)
139      (set-buffer buf)
140      (goto-char (point-min)))))
141
142;; Stolen from red gnus nntp.el
143(defun url-open-rlogin (name buffer host service)
144  "Open a connection using rsh."
145  (if (not (stringp service))
146      (setq service (int-to-string service)))
147  (let ((proc (if url-gateway-rlogin-user-name
148		  (start-process
149		   name buffer "rsh"
150		   url-gateway-rlogin-host "-l" url-gateway-rlogin-user-name
151		   (mapconcat 'identity
152			      (append url-gateway-rlogin-parameters
153				      (list host service)) " "))
154		(start-process
155		 name buffer "rsh" url-gateway-rlogin-host
156		 (mapconcat 'identity
157			    (append url-gateway-rlogin-parameters
158				    (list host service))
159			    " ")))))
160    (set-buffer buffer)
161    (url-wait-for-string "^\r*200" proc)
162    (beginning-of-line)
163    (delete-region (point-min) (point))
164    proc))
165
166;; Stolen from red gnus nntp.el
167(defun url-open-telnet (name buffer host service)
168  (if (not (stringp service))
169      (setq service (int-to-string service)))
170  (with-current-buffer (get-buffer-create buffer)
171    (erase-buffer)
172    (let ((proc (start-process name buffer "telnet" "-8"))
173	  (case-fold-search t))
174      (when (memq (process-status proc) '(open run))
175	(process-send-string proc "set escape \^X\n")
176	(process-send-string proc (concat
177				   "open " url-gateway-telnet-host "\n"))
178	(url-wait-for-string url-gateway-telnet-login-prompt proc)
179	(process-send-string
180	 proc (concat
181	       (or url-gateway-telnet-user-name
182		   (setq url-gateway-telnet-user-name (read-string "login: ")))
183	       "\n"))
184	(url-wait-for-string url-gateway-telnet-password-prompt proc)
185	(process-send-string
186	 proc (concat
187	       (or url-gateway-telnet-password
188		   (setq url-gateway-telnet-password
189			 (read-passwd "Password: ")))
190	       "\n"))
191	(erase-buffer)
192	(url-wait-for-string url-gateway-prompt-pattern proc)
193	(process-send-string
194	 proc (concat (mapconcat 'identity
195				 (append url-gateway-telnet-parameters
196					 (list host service)) " ") "\n"))
197	(url-wait-for-string "^\r*Escape character.*\r*\n+" proc)
198	(delete-region (point-min) (match-end 0))
199	(process-send-string proc "\^]\n")
200	(url-wait-for-string "^telnet" proc)
201	(process-send-string proc "mode character\n")
202	(accept-process-output proc 1)
203	(sit-for 1)
204	(goto-char (point-min))
205	(forward-line 1)
206	(delete-region (point) (point-max)))
207      proc)))
208
209;;;###autoload
210(defun url-open-stream (name buffer host service)
211  "Open a stream to HOST, possibly via a gateway.
212Args per `open-network-stream'.
213Will not make a connection if `url-gateway-unplugged' is non-nil.
214Might do a non-blocking connection; use `process-status' to check."
215  (unless url-gateway-unplugged
216    (let ((gw-method (if (and url-gateway-local-host-regexp
217			      (not (eq 'tls url-gateway-method))
218			      (not (eq 'ssl url-gateway-method))
219			      (string-match
220			       url-gateway-local-host-regexp
221			       host))
222			 'native
223		       url-gateway-method))
224;;; 	;; This hack is for OS/2 Emacs so that it will not do bogus CRLF
225;;; 	;; conversions while trying to be 'helpful'
226;;; 	(tcp-binary-process-output-services (if (stringp service)
227;;; 						(list service)
228;;; 					      (list service
229;;; 						    (int-to-string service))))
230
231	  ;; An attempt to deal with denied connections, and attempt
232	  ;; to reconnect
233	  (cur-retries 0)
234	  (retry t)
235	  (errobj nil)
236	  (conn nil))
237
238      ;; If the user told us to do DNS for them, do it.
239      (if url-gateway-broken-resolution
240	  (setq host (url-gateway-nslookup-host host)))
241
242      (condition-case errobj
243	  ;; This is a clean way to ensure the new process inherits the
244	  ;; right coding systems in both Emacs and XEmacs.
245	  (let ((coding-system-for-read 'binary)
246		(coding-system-for-write 'binary))
247	    (setq conn (case gw-method
248			 (tls
249			  (open-tls-stream name buffer host service))
250			 (ssl
251			  (open-ssl-stream name buffer host service))
252			 ((native)
253			  ;; Use non-blocking socket if we can.
254			  (make-network-process :name name :buffer buffer
255						:host host :service service
256						:nowait
257						(featurep 'make-network-process '(:nowait t))))
258			 (socks
259			  (socks-open-network-stream name buffer host service))
260			 (telnet
261			  (url-open-telnet name buffer host service))
262			 (rlogin
263			  (url-open-rlogin name buffer host service))
264			 (otherwise
265			  (error "Bad setting of url-gateway-method: %s"
266				 url-gateway-method)))))
267        ;; Ignoring errors here seems wrong.  E.g. it'll throw away the
268        ;; error signalled two lines above.  It was also found inconvenient
269        ;; during debugging.
270	;; (error
271	;;  (setq conn nil))
272	)
273      conn)))
274
275(provide 'url-gw)
276
277;; arch-tag: 1c4c0317-6d03-45b8-b3f3-838bd8f9d838
278;;; url-gw.el ends here
279