;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XLIB -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: 
;;;                       Module: 
;;;                       Version: 1.0
;;;
;;; File: /usr/local/lisp/xit/kernel/clx-auth.lisp
;;; File Creation Date: 14-Feb-92
;;; Author: Simon Leinen (simon@lia.di.epfl.ch)
;;; Description:  Reading X Authority Databases
;;; Last Modification Time: 08/12/92 15:41:42
;;; Last Modification By: Matthias Ressel
;;;
;;; 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 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)
;;; [should work with other releases of these Lisps as well.]
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;;_____________________________________________________________________________

(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 <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))

(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
