lisp/url/url-gw.el

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