From 74ceff1ec43de33a89286432c198c6d69eab754a Mon Sep 17 00:00:00 2001 From: dan Date: Sun, 9 Feb 2003 11:03:13 -0800 Subject: [PATCH] Allows the use of CLX clients over an ssh-forwarded connection. Allows the use of CLX clients over an ssh-forwarded connection. Thanks to Eric Marsden for explaining this one and writing the code in CMUCL CLX that fixes it. The X authority database is a small file typically found in $HOME/.Xauthority, each of the records in which is a binary-encoded tuple of (protocol address display-num auth-scheme-name auth-data) protocol is typically FamilyInternet or FamilyDECnet or something. The interpretation of address is protocol-specific, the display is a number, and the auth-data depends on the auth-scheme-name. With that said, I don't know of any any authorization schemes other than MIT-MAGIC-COOKIE-1, for which the auth data is 16 bytes of binary guck. For FamilyInternet, the address is just the IP address. That's easy. However, the authority database may be shared between multiple machines (for example, if you have NFS-mounted $HOME), so it has to do something special with local transports (unix sockets, shm, etc) so that they don't all overwrite each other. xauth invents some more Family* constants: the important one here is FamilyLocal, for which the address is the machine hostname as returned by gethostname(). If your DISPLAY is set to ":n" or "unix:n", this conventionally indicates a local connection, so these go into xauthority as FamilyLocal, wich the machine hostname to disambiguate them. Many people use SSH X connection forwarding to securely open remote X displays. If you're on host A, and you ssh to host B with X connection forwarding (ssh -X B), the daemon on host B opens a server socket bound to 127.0.0.1, port 6010 , then sets up your DISPLAY variable as localhost:10 (6011, 6012 etc as more connections are made). So, we have the same problem here as we do with local connections: 127.0.0.1 is localhost _everywhere_, so xauth actually specialcases any host whose address is 127.0.0.1 in the same way as it does "" and "unix" In summary, then, the necessary action to open a connection to the nth ssh-forwarded server on a machine is 1) obtain authentication data for FamilyLocal, display n+10 2) open the display at FamilyInternet host localhost port n+6010 darcs-hash:20030209190313-2591e-21921051977c5b3ba91bbd38241e666cb26a6687.gz --- clx.lisp | 12 ++++++++++++ dependent.lisp | 20 ++++++++++++++------ display.lisp | 37 +++++++++++++++++++++++++------------ 3 files changed, 51 insertions(+), 18 deletions(-) diff --git a/clx.lisp b/clx.lisp index 42a37dc..7875b6b 100644 --- a/clx.lisp +++ b/clx.lisp @@ -504,6 +504,18 @@ :static) #+sbcl #'equalp) +(defparameter *protocol-families* + '(;; X11/X.h, Family* + (:internet . 0) + (:decnet . 1) + (:chaos . 2) + ;; X11/Xauth.h "not part of X standard" + (:Local . 256) + (:Wild . 65535) + (:Netname . 254) + (:Krb5Principal . 253) + (:LocalHost . 252))) + (deftype win-gravity () '(member :unmap :north-west :north :north-east :west :center :east :south-west :south :south-east :static)) diff --git a/dependent.lisp b/dependent.lisp index 78764f8..dd4568f 100644 --- a/dependent.lisp +++ b/dependent.lisp @@ -2546,7 +2546,7 @@ (let ((hostent (get-host-by-name (string host)))) (ecase family ((:internet nil 0) - (cons :internet (coerce (host-ent-address hostent) 'list))))))) + (cons :internet (coerce (host-ent-address hostent) 'list)))))) #+explorer ;; This isn't required, but it helps make sense of the results from access-hosts (defun get-host (host-object) @@ -2643,6 +2643,15 @@ #+sbcl (sb-ext:posix-getenv name) #-(or sbcl excl lcl3.0 CMU) (progn name nil)) +(defun get-host-name () + "Return the same hostname as gethostname(3) would" + ;; machine-instance probably works on a lot of lisps, but clisp is not + ;; one of them + #+(or cmu sbcl) (machine-instance) + ;; resources-pathname was using short-site-name for this purpose + #+excl (short-site-name) + #-(or excl cmu sbcl) (error "get-host-name not implemented")) + (defun homedir-file-pathname (name) (and #-(or unix mach) (search "Unix" (software-type) :test #'char-equal) (merge-pathnames (user-homedir-pathname) (pathname name)))) @@ -2660,9 +2669,8 @@ (or (let ((string (getenv "XENVIRONMENT"))) (and string (pathname string))) - (homedir-file-pathname (concatenate 'string ".Xdefaults-" - #+excl (short-site-name) - #-excl (machine-instance))))) + (homedir-file-pathname + (concatenate 'string ".Xdefaults-" (get-host-name))))) ;;; AUTHORITY-PATHNAME - The pathname of the authority file. @@ -2677,7 +2685,7 @@ (defun get-default-display () "Get the default X display as list of (host display-number screen protocol). In UNIX this is selected using the DISPLAY environment variable, and -may use :internet or :unix protocol" +may use :internet or :local protocol" (let* ((name (or (getenv "DISPLAY") (error "DISPLAY environment variable is not set"))) (colon-i (position #\: name)) @@ -2689,7 +2697,7 @@ may use :internet or :unix protocol" (screen (if dot-i (ignore-errors (parse-integer name :start (1+ dot-i))))) (protocol (if (or (string= host "") (string-equal host "unix")) - :unix + :local :internet))) (list host (or display 0) (or screen 0) protocol))) diff --git a/display.lisp b/display.lisp index 4042f94..75d6094 100644 --- a/display.lisp +++ b/display.lisp @@ -62,18 +62,20 @@ (let* ((address (read-short-length-vector stream)) (number (parse-integer (read-short-length-string stream))) (name (read-short-length-string stream)) - (data (read-short-length-vector stream))) + (data (read-short-length-vector stream)) + (family (or (car (rassoc family *protocol-families*)) family))) (list - (case family - (0 :internet) (1 :dna) (2 :chaos) (256 :unix) (t :unknown)) - (if (eq family 256) (map 'string #'code-char address) address) + family + (ecase family + (:local (map 'string #'code-char address)) + (:internet (coerce address 'list))) number name data)))))) (defun get-best-authorization (host display protocol) ;; parse .Xauthority, extract the cookie for DISPLAY on HOST. ;; PROTOCOL determines whether the server connection is using an - ;; Internet protocol (values of :tcp or :internet) or a non-network - ;; protocol such as Unix domain sockets (value of :unix). Returns + ;; Internet protocol (value of :internet) or a non-network + ;; protocol such as Unix domain sockets (value of :local). Returns ;; two strings: an authorization name (very likely the string ;; "MIT-MAGIC-COOKIE-1") and an authorization key, represented as ;; fixnums in a vector. If we fail to find an appropriate cookie, @@ -83,17 +85,23 @@ (with-open-file (stream pathname :element-type '(unsigned-byte 8) :if-does-not-exist nil) (when stream - (let* ((host-address (unless (eql protocol :unix) - (rest (host-address host protocol)))) + (let* ((host-address (and (eql protocol :internet) + (rest (host-address host protocol)))) (best-name nil) (best-pos nil) (best-data nil)) + ;; Check for the localhost address, in which case we're + ;; really FamilyLocal. + (when (or (eql protocol :local) + (and (eql protocol :internet) + (equal host-address '(127 0 0 1)))) + (setq host-address (get-host-name)) + (setq protocol :local)) (loop (destructuring-bind (family address number name data) (read-xauth-entry stream) (unless family (return)) (when (and (eql family protocol) - (or (eql protocol :unix) - (equal host-address (coerce address 'list))) + (equal host-address address) (= number display) (let ((pos1 (position name *known-authorizations* :test #'string=))) @@ -314,6 +322,11 @@ ,@(and timeout `(:timeout ,timeout))) ,@body)))) +(defun open-default-display () + (destructuring-bind (host display screen protocol) (get-default-display) + (declare (ignore screen)) + (open-display host :display display :protocol protocol))) + (defun open-display (host &key (display 0) protocol authorization-name authorization-data) ;; Implementation specific routine to setup the buffer for a ;; specific host and display. This must interface with the local @@ -328,13 +341,13 @@ (declare (clx-values display)) ;; Get the authorization mechanism from the environment. Handle the ;; special case of a host name of "" and "unix" which means the - ;; protocol is :unix + ;; protocol is :local (when (null authorization-name) (multiple-value-setq (authorization-name authorization-data) (get-best-authorization host display (if (member host '("" "unix") :test #'equal) - :unix + :local protocol)))) ;; PROTOCOL is the network protocol (something like :TCP :DNA or :CHAOS). See OPEN-X-STREAM. (let* ((stream (open-x-stream host display protocol))