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