;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: CLX Goodies
;;;                       Version: 1.0
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Matthias Ressel
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/kernel/authorization.lisp
;;; File Creation Date: 06/12/92 16:49:19
;;; Last Modification Time: 06/12/92 16:53:45
;;; Last Modification By: Matthias Ressel
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;;_____________________________________________________________________________

;;; Utility for running XIT on a display that has access controlled by user authorization
;;; Might actually belong into CLX.

(defstruct authorization-cookie
  name data)

(defun get-user-authorizations (host display-number)
  "Returns a alist of authorization cookies derived from the user's .Xauthority file."
  (let* ((display-string (format nil "~a:~a" host display-number))
	 (command-string (format nil "xauth extract - ~a" display-string))
	 (exit-status nil))
    (multiple-value-bind (input-stream error-stream process-id)
	(excl::run-shell-command
	 command-string :output :stream :wait nil)
      (loop
	(multiple-value-bind (status completed-process-id) 
	    (sys:os-wait)
	  (when (or (null status)
		    (eq completed-process-id process-id))
	    (setq exit-status status)
	    (return))))
      (if (and (zerop exit-status) input-stream)
	  (let* ((authorizations '())
		 (cookie-string (read-line input-stream nil input-stream))
		 (cookie-string-length nil)
		 (start 0))
	    (unless (eq cookie-string input-stream)
	      (setq cookie-string-length (length cookie-string))
	      (loop
		(when (>= start cookie-string-length)
		  (return (nreverse authorizations)))
		(multiple-value-bind (cookie-name data end)
		    (parse-authorization-entry cookie-string start)
		  (push (make-authorization-cookie :name cookie-name
						   :data data)
			authorizations)
		  (setq start end)))))))))

(defun parse-authorization-entry (string &optional (start 0))
  "Returns the cookie name, the data, and the end of read part of given STRING.
The parsing begins at the START position."
  (let* ((host-name-length (parse-authorization-entry-length string (+ start 2) 2))
	 (cookie-name-start (+ start host-name-length 9))
	 (cookie-name-end
	  (+ cookie-name-start
	     (parse-authorization-entry-length string (- cookie-name-start 2) 2)))
	 (cookie-data-start (+ cookie-name-end 2))
	 (cookie-data-end
	  (+ cookie-data-start
	     (parse-authorization-entry-length string (- cookie-data-start 2) 2))))
    (values (subseq string cookie-name-start cookie-name-end)
	    (subseq string cookie-data-start cookie-data-end)
	    cookie-data-end)))


(defun parse-authorization-entry-length (string start len)
  "Interpret the next LEN chars as bytes forming a integer describing a field length."
  (let* ((index start)
	 (length (char-code (char string index))))
    (dotimes (i (1- len))
      (incf index)
      (setq length (+ (char-code (char string index))
		      (* length 256))))
    length))

#||
(defun do-open-toplevel-display (&optional name
				 &rest display-options
				 &key (host *default-host*)
				      (display *default-display*))
  (when (and host display)
    (let* ((user-authorizations (get-user-authorizations host display))
	   (auth-args`(:authorization-name ,(authorization-cookie-name authorization)
		       :authorization-data ,(authorization-cookie-data authorization)))
	   (display nil))
    (dolist (authorization user-authorizations)
      (setq display (apply #'open-contact-display (or name 'toplevel-display)
			   (append display-options authargs)))
      (when display
	(call-open-display-hooks display)
	(return display))))))
||#
	  
	  
  
  
  
		  
	    
	    