code.delx.au - gnu-emacs/blob - lisp/url/url-gw.el

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