[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
cookie-based authoritization in CLX (was: Re: hemlock display)
The following code can be used to extract the authorization keys
from a file specified by the XAUTHORITY variable (falling back to
".Xauthority" in the user-homedir if this is not set).
Reading environment variables is of course system-dependent... I have
tested it in Allegro (4.1 beta) and CMU CL (15d).
The other non-portable feature I use is the hostname->address
translation (because in the Xauthority file you always have
addresses). "dependent.lisp" in CLX defines a function HOST-ADDRESS
for some systems (Explorer, Genera and Minima). I use this function
and added the definitions for Allegro and CMU CL.
The auth file is read as a character stream, but it should really be
an (INTEGER 0 255) byte stream or some such.
--
Simon.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; File Name: clx-auth.lisp
;;; Description: Reading X Authority Databases
;;; Author: Simon Leinen (simon@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.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; These replacement versions of the R4 and R5 CLX open-display
;;; functions try 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).
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package "XLIB")
#-CLX-MIT-R4
(defun open-display (host &rest options &key (display 0) protocol
authorization-name authorization-data &allow-other-keys)
;; Changed by Simon Leinen <simon@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))
#+CLX-MIT-R4
(defun open-display (host &rest options &key (display 0) protocol
authorization-name authorization-data &allow-other-keys)
(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
#x2000 '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 (&optional host)
(let ((xauthority (getenv "XAUTHORITY")))
(or xauthority
(make-pathname
:name ".Xauthority"
:defaults (user-homedir-pathname host)))))
(defun getenv (name)
#+Allegro (sys:getenv name)
#+Lucid (lcl:environment-value 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))))))))