lisp/url/url-gw.el

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