CLX and xauth
Stig Hemmer
problem.
CLX doesn't implement any authorization. That is, it accepts
autorization data as an argument to OPEN-DISPLAY, but has no function
for digging this data from .Xauthority files.
Somebody must have solved this problem before. Probably a lot of
somebodies have. Does anybody want to share their solution?
I use Allegro CL version 5.0.1 Trial Edition from Franz
(www.franz.com). I'm currently using the FreeBSD version, but can
switch to Linux if needed.
I use the CLX supplied with Allegro, I don't know if it is any
different from "original" CLX, if there is such a thing.
Stig Hemmer,
Jack of a Few Trades.
Erik Naggum
| I use the CLX supplied with Allegro, I don't know if it is any
| different from "original" CLX, if there is such a thing.
check for updates at ftp.franz.com or just call SYS:UPDATE-ALLEGRO from
the top-level as a user who is allowed to write into the installation
directories.
I'm a bit starved for bandwidth at the moment, so I can't check the hunch
that this was recently improved and posted as an update.
#:Erik
Simon Leinen
> Hi, I've started fidling with CLX [Common Lisp X bindings] and have a
> problem.
> CLX doesn't implement any authorization. That is, it accepts
> autorization data as an argument to OPEN-DISPLAY, but has no function
> for digging this data from .Xauthority files.
> Somebody must have solved this problem before. Probably a lot of
> somebodies have. Does anybody want to share their solution?
Sure---hope this still works.
--
Simon. http://www.switch.ch/misc/leinen/
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; File Name: clx-auth.lisp
;;; Description: Reading X Authority Databases
;;; Author: Simon Leinen (si...@lia.di.epfl.ch)
;;; Date Created: 14-Feb-92
;;; RCS $Header$
;;; RCS $Log$
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;; Copyright (C) 1992 Ecole Polytechnique Federale de Lausanne
;;;
;;; Permission is granted to any individual or institution to use,
;;; copy, modify, and distribute this software, provided that this
;;; complete copyright and permission notice is maintained, intact, in
;;; all copies and supporting documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
;;; EPFL provides this software "as is" without express or implied
;;; warranty.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This replacement version of the CLX open-display function tries to
;;; retrieve the authorization data for the given display from a file.
;;; The name of the authorization file is given by the XAUTHORITY
;;; environment variable. If this variable is not set, a file named
;;; ".Xauthority" under the user's home directory is scanned. In
;;; connection with automatic cookie setup as with XDM, this change
;;; increases network transparency (and security).
;;;
;;; Tested on:
;;; CMU CL 16d and 16e (Sun 4)
;;; Allegro CL 4.1 (Sun 4) and 4.1BETA (SGI)
;;; Lucid CL 4.0.2 (Sun 4)
;;; Genera 8.0.2 (UX Ivory)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package "XLIB")
#-CLX-MIT-R5
(defvar *output-buffer-size* 8192)
(defun open-display (host &rest options &key (display 0) protocol
authorization-name authorization-data &allow-other-keys)
;; Changed by Simon Leinen <si...@lia.di.epfl.ch>:
;; If no authorization information is given, try to find it out.
;;
(declare (type integer display)
(dynamic-extent options))
(declare (values display))
(unless (or authorization-name authorization-data)
(multiple-value-setq (authorization-name authorization-data)
(get-authorization-key host display protocol)))
;; PROTOCOL is the network protocol (something like :TCP :DNA or :CHAOS). See OPEN-X-STREAM.
(let* ((stream (open-x-stream host display protocol))
(disp (apply #'make-buffer
*output-buffer-size*
'make-display-internal
:host host
:display display
:output-stream stream
:input-stream stream
:allow-other-keys t
options))
(ok-p nil))
(unwind-protect
(progn
(display-connect disp
:authorization-name authorization-name
:authorization-data authorization-data)
(initialize-resource-allocator disp)
(initialize-predefined-atoms disp)
(initialize-extensions disp)
(setq ok-p t))
(unless ok-p (close-display disp :abort t)))
disp))
(defun get-authorization-key (host display protocol)
(let ((auth-file (authority-file-name)))
(if (not (probe-file auth-file))
(values nil nil)
(let ((display-number-as-string (prin1-to-string display)))
(ecase protocol
((:tcp nil)
(let ((host-address (host-address host :internet)))
(with-open-file (auth auth-file)
(loop
(multiple-value-bind (address number name data)
(read-xauth-entry auth)
(unless address
(return nil))
(when (and (equal host-address address)
(string= number display-number-as-string))
(return (values name data)))))))))))))
(defun authority-file-name ()
(let ((xauthority (getenv "XAUTHORITY")))
(or xauthority
#-Genera
(make-pathname
:name ".Xauthority"
:type nil
:defaults (user-homedir-pathname))
#+Genera
(make-pathname
:name ""
:type "Xauthority"
:defaults (user-homedir-pathname)))))
(defun getenv (name)
#+Allegro (sys:getenv name)
#+Lucid (lcl:environment-variable name)
#+CMU (cdr (assoc name ext:*environment-list* :test #'string=))
#-(or Allegro Lucid CMU)
nil)
(defun read-xauth-entry (stream)
(let ((family (net-read-short stream nil)))
(and family
(let* ((address (net-read-short-length-string stream))
(number (net-read-short-length-string stream))
(name (net-read-short-length-string stream))
(data (net-read-short-length-string stream)))
(values (decode-address family address) number name data)))))
(defun decode-address (family address)
(ecase family
((0)
(list :internet (char-int (schar address 0))
(char-int (schar address 1))
(char-int (schar address 2))
(char-int (schar address 3))))
((256)
;; is it ok to return address as a string?
(list :unix address))))
(defun net-read-short (stream &optional (errorp t) (eof-value nil))
(let ((high-byte-char (read-char stream errorp nil)))
(if (not high-byte-char)
eof-value
(+ (* (char-int high-byte-char) 256)
(char-int (read-char stream))))))
(defun net-read-short-length-string (stream)
(let ((length (net-read-short stream)))
(let ((string (make-string length)))
(dotimes (k length)
(setf (schar string k) (read-char stream)))
string)))
#+Allegro
(defun host-address (host &optional (family :internet))
(labels ((no-host-error ()
(error "Unknown host ~S" host))
(no-address-error ()
(error "Host ~S has no ~S address" host family)))
(let ((hostent (ipc::gethostbyname host)))
(unwind-protect
(progn
(when (zerop hostent)
(no-host-error))
(ecase family
((:internet)
(unless (= (ipc::hostent-addrtype hostent) 2)
(no-address-error))
(assert (= (ipc::hostent-length hostent) 4))
(let ((addr (ipc::hostent-addr hostent)))
(when (or (member comp::.target.
'(:hp :sgi4d :sony :dec3100)
:test #'eq)
(probe-file "/lib/ld.so"))
;; BSD 4.3 based systems require an extra indirection
(setq addr (si:memref-int addr 0 0 :unsigned-long)))
(list :internet
(si:memref-int addr 0 0 :unsigned-byte)
(si:memref-int addr 1 0 :unsigned-byte)
(si:memref-int addr 2 0 :unsigned-byte)
(si:memref-int addr 3 0 :unsigned-byte))))))
(ff:free-cstruct hostent)))))
#+CMU
(defun host-address (host &optional (family :internet))
(labels ((no-host-error ()
(error "Unknown host ~S" host))
(no-address-error ()
(error "Host ~S has no ~S address" host family)))
(let ((hostent (ext:lookup-host-entry host)))
(when (not hostent)
(no-host-error))
(ecase family
((:internet)
(unless (= (ext::host-entry-addr-type hostent) 2)
(no-address-error))
(let ((addr (first (ext::host-entry-addr-list hostent))))
(list :internet
(ldb (byte 8 24) addr)
(ldb (byte 8 16) addr)
(ldb (byte 8 8) addr)
(ldb (byte 8 0) addr))))))))
#+Lucid
(progn
(lcl:def-foreign-struct sockaddr-in
(family :type :signed-16bit)
(port :type :unsigned-16bit)
(addr :type (:array :unsigned-8bit (4)))
(zero :type (:array :signed-8bit (8))))
(lcl:def-foreign-struct hostent
(h_name :type (:pointer :char))
(h_aliases :type (:pointer (:pointer :char)))
(h_addrtype :type :signed-32bit)
(h_length :type :signed-32bit)
(h_addr_list :type (:pointer (:array (:pointer :char) (1)))))
(lcl:def-foreign-function
(libc-gethostbyname (:return-type (:pointer hostent))
(:name "_gethostbyname")
(:language :c))
(name (:pointer :character)))
(defun malloc-foreign-string (string)
(check-type string string)
(let ((foreign-string
(lcl:malloc-foreign-pointer
:type
`(:pointer (:array :character (,(1+ (length string))))))))
(setf (lcl:foreign-string-value foreign-string) string)
(setf (lcl:foreign-pointer-type foreign-string)
'(:pointer :character))
foreign-string))
(defun host-address (name &optional (family :internet))
(check-type name string)
(let ((foreign-name (malloc-foreign-string name)))
(unwind-protect
(let ((hostent (libc-gethostbyname foreign-name)))
(if (zerop (lcl:foreign-pointer-address hostent))
nil
(case (hostent-h_addrtype hostent)
((2) ;AF_INET
(and (eq family :internet)
(cons :internet
(make-ip-address
(lcl:foreign-aref
(hostent-h_addr_list hostent)
0)))))
(otherwise nil))))
(lcl:free-foreign-pointer foreign-name))))
(defun make-ip-address (foreign-char-pointer)
(setf (lcl:foreign-pointer-type foreign-char-pointer)
'(:pointer (:array :unsigned-8bit (4))))
(list (lcl:foreign-aref foreign-char-pointer 0)
(lcl:foreign-aref foreign-char-pointer 1)
(lcl:foreign-aref foreign-char-pointer 2)
(lcl:foreign-aref foreign-char-pointer 3)))
);; #+Lucid