lisp/url/url-gw.el

   1 ;;; url-gw.el --- Gateway munging for URL loading
   2
   3 ;; Copyright (C) 1997, 1998, 2004, 2005 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'.
  63 This 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'.
  74 This 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.
 100 This should be used when your version of Emacs cannot correctly use DNS,
 101 but your machine can.  This usually happens if you are running a statically
 102 linked 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         (save-excursion
 122           (set-buffer (process-buffer proc))
 123           (while (memq (process-status proc) '(run open))
 124             (accept-process-output proc))
 125           (goto-char (point-min))
 126           (if (re-search-forward "Name:.*\nAddress: *\\(.*\\)$" nil t)
 127               (setq res (buffer-substring (match-beginning 1)
 128                                           (match-end 1))))
 129           (kill-buffer (current-buffer)))
 130         res)
 131     host))
 132
 133 ;; Stolen from red gnus nntp.el
 134 (defun url-wait-for-string (regexp proc)
 135   "Wait until string matching REGEXP arrives in process PROC's buffer."
 136   (let ((buf (current-buffer)))
 137     (goto-char (point-min))
 138     (while (not (re-search-forward regexp nil t))
 139       (accept-process-output proc)
 140       (set-buffer buf)
 141       (goto-char (point-min)))))
 142
 143 ;; Stolen from red gnus nntp.el
 144 (defun url-open-rlogin (name buffer host service)
 145   "Open a connection using rsh."
 146   (if (not (stringp service))
 147       (setq service (int-to-string service)))
 148   (let ((proc (if url-gateway-rlogin-user-name
 149                   (start-process
 150                    name buffer "rsh"
 151                    url-gateway-rlogin-host "-l" url-gateway-rlogin-user-name
 152                    (mapconcat 'identity
 153                               (append url-gateway-rlogin-parameters
 154                                       (list host service)) " "))
 155                 (start-process
 156                  name buffer "rsh" url-gateway-rlogin-host
 157                  (mapconcat 'identity
 158                             (append url-gateway-rlogin-parameters
 159                                     (list host service))
 160                             " ")))))
 161     (set-buffer buffer)
 162     (url-wait-for-string "^\r*200" proc)
 163     (beginning-of-line)
 164     (delete-region (point-min) (point))
 165     proc))
 166
 167 ;; Stolen from red gnus nntp.el
 168 (defun url-open-telnet (name buffer host service)
 169   (if (not (stringp service))
 170       (setq service (int-to-string service)))
 171   (save-excursion
 172     (set-buffer (get-buffer-create buffer))
 173     (erase-buffer)
 174     (let ((proc (start-process name buffer "telnet" "-8"))
 175           (case-fold-search t))
 176       (when (memq (process-status proc) '(open run))
 177         (process-send-string proc "set escape \^X\n")
 178         (process-send-string proc (concat
 179                                    "open " url-gateway-telnet-host "\n"))
 180         (url-wait-for-string url-gateway-telnet-login-prompt proc)
 181         (process-send-string
 182          proc (concat
 183                (or url-gateway-telnet-user-name
 184                    (setq url-gateway-telnet-user-name (read-string "login: ")))
 185                "\n"))
 186         (url-wait-for-string url-gateway-telnet-password-prompt proc)
 187         (process-send-string
 188          proc (concat
 189                (or url-gateway-telnet-password
 190                    (setq url-gateway-telnet-password
 191                          (read-passwd "Password: ")))
 192                "\n"))
 193         (erase-buffer)
 194         (url-wait-for-string url-gateway-prompt-pattern proc)
 195         (process-send-string
 196          proc (concat (mapconcat 'identity
 197                                  (append url-gateway-telnet-parameters
 198                                          (list host service)) " ") "\n"))
 199         (url-wait-for-string "^\r*Escape character.*\r*\n+" proc)
 200         (delete-region (point-min) (match-end 0))
 201         (process-send-string proc "\^]\n")
 202         (url-wait-for-string "^telnet" proc)
 203         (process-send-string proc "mode character\n")
 204         (accept-process-output proc 1)
 205         (sit-for 1)
 206         (goto-char (point-min))
 207         (forward-line 1)
 208         (delete-region (point) (point-max)))
 209       proc)))
 210
 211 ;;;###autoload
 212 (defun url-open-stream (name buffer host service)
 213   "Open a stream to HOST, possibly via a gateway.
 214 Args per `open-network-stream'.
 215 Will not make a connection if `url-gateway-unplugged' is non-nil."
 216   (unless url-gateway-unplugged
 217     (let ((gw-method (if (and url-gateway-local-host-regexp
 218                               (not (eq 'tls url-gateway-method))
 219                               (not (eq 'ssl url-gateway-method))
 220                               (string-match
 221                                url-gateway-local-host-regexp
 222                                host))
 223                          'native
 224                        url-gateway-method))
 225 ;;;     ;; This hack is for OS/2 Emacs so that it will not do bogus CRLF
 226 ;;;     ;; conversions while trying to be 'helpful'
 227 ;;;     (tcp-binary-process-output-services (if (stringp service)
 228 ;;;                                             (list service)
 229 ;;;                                           (list service
 230 ;;;                                                 (int-to-string service))))
 231
 232           ;; An attempt to deal with denied connections, and attempt
 233           ;; to reconnect
 234           (cur-retries 0)
 235           (retry t)
 236           (errobj nil)
 237           (conn nil))
 238
 239       ;; If the user told us to do DNS for them, do it.
 240       (if url-gateway-broken-resolution
 241           (setq host (url-gateway-nslookup-host host)))
 242
 243       (condition-case errobj
 244           ;; This is a clean way to ensure the new process inherits the
 245           ;; right coding systems in both Emacs and XEmacs.
 246           (let ((coding-system-for-read 'binary)
 247                 (coding-system-for-write 'binary))
 248             (setq conn (case gw-method
 249                          (tls
 250                           (open-tls-stream name buffer host service))
 251                          (ssl
 252                           (open-ssl-stream name buffer host service))
 253                          ((native)
 254                           (open-network-stream name buffer host service))
 255                          (socks
 256                           (socks-open-network-stream name buffer host service))
 257                          (telnet
 258                           (url-open-telnet name buffer host service))
 259                          (rlogin
 260                           (url-open-rlogin name buffer host service))
 261                          (otherwise
 262                           (error "Bad setting of url-gateway-method: %s"
 263                                  url-gateway-method)))))
 264         (error
 265          (setq conn nil)))
 266       conn)))
 267
 268 (provide 'url-gw)
 269
 270 ;;; arch-tag: 1c4c0317-6d03-45b8-b3f3-838bd8f9d838
 271 ;;; url-gw.el ends here