Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

OPEN-X-STREAM refactoring, abstract UNIX support, IPv6 support #167

Draft
wants to merge 4 commits into
base: master
Choose a base branch
from
Draft

OPEN-X-STREAM refactoring, abstract UNIX support, IPv6 support #167

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
7f802a6
xvidmode: use explicit SINGLE-FLOAT literals where necessary
scymtym Apr 4, 2020
3d37f0d
display: OPEN-DISPLAY, OPEN-X-STREAM refactoring
scymtym Apr 4, 2020
c39dbe8
dependent: OPEN-X-STREAM supports abstract UNIX sockets on SBCL, ECL,…
scymtym Apr 29, 2020
c05518a
dependent: OPEN-X-STREAM supports IPv6 addresses on SBCL, ECL, CLASP
scymtym Apr 30, 2020
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
45 changes: 31 additions & 14 deletions depdefs.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -92,7 +92,7 @@
(declaim (declaration arglist))

;;; INDENTATION argpos1 arginden1 argpos2 arginden2 --- Tells the lisp editor how to
;;; indent calls to the function or macro containing the declaration.
;;; indent calls to the function or macro containing the declaration.

#-genera
(declaim (declaration indentation))
Expand Down Expand Up @@ -246,7 +246,7 @@

(defun make-index-op (operator args)
`(the array-index
(values
(values
,(case (length args)
(0 `(,operator))
(1 `(,operator
Expand Down Expand Up @@ -597,7 +597,7 @@ used, since NIL is the empty list.")
(dead nil :type (or null (not null)))
;; T makes buffer-flush a noop. Manipulated with with-buffer-flush-inhibited.
(flush-inhibit nil :type (or null (not null)))

;; Change these functions when using shared memory buffers to the server
;; Function to call when writing the buffer
(write-function 'buffer-write-default)
Expand All @@ -613,7 +613,7 @@ used, since NIL is the empty list.")
(listen-function 'buffer-listen-default)

#+Genera (debug-io nil :type (or null stream))
)
)

;;-----------------------------------------------------------------------------
;; Printing routines.
Expand Down Expand Up @@ -653,7 +653,7 @@ used, since NIL is the empty list.")

#+lcl3.0
(lucid::def-foreign-function
(connect-to-server
(connect-to-server
(:language :c)
(:return-type :signed-32bit))
(host :simple-string)
Expand All @@ -664,19 +664,36 @@ used, since NIL is the empty list.")
;; Finding the server socket
;;-----------------------------------------------------------------------------

(defun protocol-from-host (host protocol)
(cond ;; The special case of HOST being "" or "unix" means the
;; protocol is :local, irregardless of PROTOCOL.
((member host '("" "unix") :test #'equal)
:local)
;; PROTOCOL being :UNIX is accepted as an alias for :LOCAL.
;; PROTOCOL being :|| comes from Darwin's weird DISPLAY
;; environment variable containing values like
;; "/tmp/launch...".
((member protocol '(:unix :||) :test #'eq)
:local)
;; Treat :TCP as an alias for :INTERNET.
((eq :protocol :tcp)
:internet)
;; Keep other non-NIL values of PROTOCOL unchanged.
(protocol)
;; If PROTOCOL is NIL, assume :INTERNET.
(t
:internet)))
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

please add a comment here (maybe move it from below), that it is a special case when the host is either "" or "unix" -- protocol is then ignored. I was convinced that it is a braino until I saw a comment later in this file.

Also there is darwin with :||. Maybe:

(if (or (member host '("" "unix") :test #'equal)
    (member protocol '(:unix :||))
  :local
  (or protocol :internet))

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I tried to improve a few things around this normalization.

That said, I was mainly looking for feedback regarding the general direction and approach at this point.

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I first need to build an understanding of the general direction by looking at the code. I will keep remarks about the code to myself then.

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Thanks for the suggestion either way. I just didn't want you to waste your time on code that may turn out to be misguided.


;; These are here because dep-openmcl.lisp, dep-lispworks.lisp and
;; dependent.lisp need them
(defconstant +X-unix-socket-path+
"/tmp/.X11-unix/X"
"The location of the X socket")

(defun unix-socket-path-from-host (host display)
"Return the name of the unix domain socket for host and display, or
nil if a network socket should be opened."
(cond ((or (string= host "") (string= host "unix"))
(format nil "~A~D" +X-unix-socket-path+ display))
#+darwin
((or (and (> (length host) 10) (string= host "tmp/launch" :end1 10))
(and (> (length host) 29) (string= host "private/tmp/com.apple.launchd" :end1 29)))
(format nil "/~A:~D" host display))
(t nil)))
"Return the name of the UNIX domain socket for HOST, PROTOCOL and DISPLAY."
(if #+darwin (or (and (> (length host) 10) (string= host "tmp/launch" :end1 10))
(and (> (length host) 29) (string= host "private/tmp/com.apple.launchd" :end1 29)))
#-darwin nil
(format nil "/~A:~D" host display)
(format nil "~A~D" +X-unix-socket-path+ display)))
258 changes: 138 additions & 120 deletions dependent.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -812,7 +812,7 @@
;; It doesn't because CLtL doesn't pass the environment to GET-SETF-METHOD.

;; FIXME: both sbcl and ecl has compare-and-swap these days.
;; FIXME: Verify for clasp
;; FIXME: Verify for clasp

#-sbcl
(defmacro conditional-store (place old-value new-value)
Expand Down Expand Up @@ -858,109 +858,128 @@
;;; OPEN-X-STREAM - create a stream for communicating to the appropriate X
;;; server

#-(or CMU sbcl ecl clisp clasp)
(defun open-x-stream (host display protocol)
host display protocol ;; unused
(error "OPEN-X-STREAM not implemented yet."))
(declare (type (integer 0) display))
(flet ((lose (reason)
(error 'connection-failure :major-version *protocol-major-version*
:minor-version *protocol-minor-version*
:host host
:display display
:reason reason)))
(multiple-value-bind (socket reason)
(case protocol
;; Establish a connection to the X11 server over a Unix
;; socket.
(:local
(let ((path (unix-socket-path-from-host host display)))
(unless (probe-file path)
(lose (list "UNIX socket ~S does not exist" path)))
(make-unix-x-socket path)))
;; Establish a TCP connection to the X11 server, which is
;; listening on port 6000 + display-number.
(:internet
(make-inet-x-socket host (+ *x-tcp-port* display)))
;; TODO
(t
(lose (list "~S is not a known protocol" protocol))))
(when (null socket)
(lose reason))
(make-x-socket-stream socket))))
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

having three functions to implement instead of one doesn't sound appealing. maybe open-x-stream should provide a canonical form of arguments to the make-x-stream which is implemented for each lisp and is responsible for creating the socket/fd?

(defun make-unix-stream (&key path host port) …)

where some options are mutually exclusive

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

One downside of a single function would be a more complicated signature as evidenced by the need for mutually exclusive keyword parameters.

The other potential downside is less sharing between implementations. Going by the previous comment, maybe it is necessary to implement the function for local sockets differently for SBCL and ECL, but maybe the function for TCP sockets can still be shared.


#-(or CMU sbcl ecl clisp clasp)
(defun open-unix-x-socket (host display protocol)
(declare (ignore host display protocol))
(error "OPEN-UNIX-X-SOCKET not implemented yet."))

#+clisp
(defun open-x-stream (host display protocol)
(declare (ignore protocol)
(type (integer 0) display))
(let ((socket
;; are we dealing with a localhost?
(when (or (string= host "")
(string= host "unix"))
;; ok, try to connect to a AF_UNIX domain socket
(sys::make-socket-stream "" display))))
(if socket
socket
;; try to connect by hand
(let ((host (host-address host)))
(when host
;; Fixme: get a descent ip standard in CLX: a vector!
(let ((ip (format nil
"~{~D~^.~}"
(rest host))))
(socket:socket-connect (+ 6000 display) ip
:element-type '(unsigned-byte 8))))))))

#+(or sbcl ecl)
(defun open-x-stream (host display protocol)
(declare (ignore protocol)
(type (integer 0) display))
(socket-make-stream
(let ((unix-domain-socket-path (unix-socket-path-from-host host display)))
(if unix-domain-socket-path
(let ((s (make-instance 'local-socket :type :stream)))
(socket-connect s unix-domain-socket-path)
s)
(let ((host (car (host-ent-addresses (get-host-by-name host)))))
(when host
(let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)))
(socket-connect s host (+ 6000 display))
s)))))
:element-type '(unsigned-byte 8)
:input t :output t :buffering :none))
(defun make-unix-x-socket (path)
(sys::make-socket-stream "" path))

#+clasp
(defun open-x-stream (host display protocol)
(declare (ignore protocol)
(type (integer 0) display))
(SB-BSD-SOCKETS:socket-make-stream
(let ((unix-domain-socket-path (unix-socket-path-from-host host display)))
(if unix-domain-socket-path
(let ((s (make-instance 'SB-BSD-SOCKETS:local-socket :type :stream)))
(SB-BSD-SOCKETS:socket-connect s unix-domain-socket-path)
s)
(let ((host (car (SB-BSD-SOCKETS:host-ent-addresses (SB-BSD-SOCKETS:get-host-by-name host)))))
(when host
(let ((s (make-instance 'SB-BSD-SOCKETS:inet-socket :type :stream :protocol :tcp)))
(SB-BSD-SOCKETS:socket-connect s host (+ 6000 display))
s)))))
:element-type '(unsigned-byte 8)
:input t :output t :buffering :none))
#+clisp
(defun make-inet-x-socket (host port)
(let ((host (host-address host)))
(when host
;; Fixme: get a descent ip standard in CLX: a vector!
(let ((ip (format nil "~{~D~^.~}" (rest host))))
(socket:socket-connect port ip :element-type '(unsigned-byte 8))))))

#+clisp
(defun make-x-socket-stream (socket)
socket)

#+(or sbcl ecl clasp)
(defun make-unix-x-socket (path)
(let ((errors '()))
(flet ((try (socket-class path)
(handler-case
(let ((socket (make-instance socket-class :type :stream)))
(socket-connect socket path)
socket)
(error (condition)
(push (list socket-class condition) errors)
nil))))
(or (try 'local-abstract-socket path)
(try 'local-socket path)
(values nil (list "~@<Could not connect to X server socket ~
via UNIX socket ~S:~@:_~
~{~{* ~@<Using a ~S failed: ~
~A~@:>~}~^~@:_~}~:>"
path errors))))))
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

neither class is implemented in ecl. I understand that it is meant to be future-proof, but in that case maybe adding a fallback operation which prepends 0 to the path (could be used for other implementations too) is a good idea?

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I thought ECL and Clasp copied the entire interface. I will have to rethink the approach.


#+(or sbcl ecl clasp)
(defun make-inet-x-socket (host port)
(multiple-value-bind (host-ent/v4 host-ent/v6)
(handler-case
(get-host-by-name host)
(error (condition)
(return-from make-inet-x-socket
(values nil (list "~@<Host ~S not found: ~A~@:>" host condition)))))
(let ((addresses/v4 (host-ent-addresses host-ent/v4))
(addresses/v6 (when host-ent/v6
(host-ent-addresses host-ent/v6)))
(errors '()))
(flet ((try (socket-class addresses)
(let ((address (first addresses)))
(handler-case
(let ((socket (make-instance socket-class :type :stream :protocol :tcp)))
(socket-connect socket address port)
socket)
(error (condition)
(push (list socket-class address condition) errors)
nil)))))
(or (when addresses/v4 (try 'inet-socket addresses/v4))
(when addresses/v6 (try 'inet6-socket addresses/v6))
(values nil (list "~@<Could not connect to X server socket ~
on host ~S, port ~S:~@:_~
~{~{* ~@<Using ~S address ~S failed: ~
~A~@:>~}~^~@:_~}~:>"
host port errors)))))))

#+(or sbcl ecl clasp)
(defun make-x-socket-stream (socket)
(socket-make-stream socket :element-type '(unsigned-byte 8)
:input t :output t :buffering :none))
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

name socket may be a bit misleading, make-x-stream, which directly corresponds to open-x-stream?


#+cmu
(defun open-x-stream (host display protocol)
(let ((stream-fd
(ecase protocol
;; establish a TCP connection to the X11 server, which is
;; listening on port 6000 + display-number
((:internet :tcp nil)
(let ((fd (ext:connect-to-inet-socket host (+ *x-tcp-port* display))))
(unless (plusp fd)
(error 'connection-failure
:major-version *protocol-major-version*
:minor-version *protocol-minor-version*
:host host
:display display
:reason (format nil "Cannot connect to internet socket: ~S"
(unix:get-unix-error-msg))))
fd))
;; establish a connection to the X11 server over a Unix
;; socket. (:|| comes from Darwin's weird DISPLAY
;; environment variable)
((:unix :local :||)
(let ((path (unix-socket-path-from-host host display)))
(unless (probe-file path)
(error 'connection-failure
:major-version *protocol-major-version*
:minor-version *protocol-minor-version*
:host host
:display display
:reason (format nil "Unix socket ~s does not exist" path)))
(let ((fd (ext:connect-to-unix-socket (namestring path))))
(unless (plusp fd)
(error 'connection-failure
:major-version *protocol-major-version*
:minor-version *protocol-minor-version*
:host host
:display display
:reason (format nil "Can't connect to unix socket: ~S"
(unix:get-unix-error-msg))))
fd))))))
(system:make-fd-stream stream-fd :input t :output t :element-type '(unsigned-byte 8))))
(defun make-unix-x-socket (path)
(let ((fd (ext:connect-to-unix-socket (namestring path))))
(if (plusp fd)
fd
(values nil (list "Can't connect to unix socket: ~S"
(unix:get-unix-error-msg))))))

#+cmu
(defun make-inet-x-socket (host port)
(let ((fd (ext:connect-to-inet-socket host port)))
(if (plusp fd)
fd
(return-from make-inet-x-socket
(values nil (list "Cannot connect to internet socket: ~S"
(unix:get-unix-error-msg)))))))

#+cmu
(defun make-x-socket-stream (socket)
(system:make-fd-stream socket :input t :output t :element-type '(unsigned-byte 8)))

;;; BUFFER-READ-DEFAULT for CMU Common Lisp.
;;;
Expand Down Expand Up @@ -1622,30 +1641,29 @@ C language bindings
Returns a list of (host display-number screen protocol)."
(let* ((name (or display-name
(getenv "DISPLAY")
(error "DISPLAY environment variable is not set")))
(error "DISPLAY environment variable is not set.")))
(slash-i (or (position #\/ name) -1))
(colon-i (position #\: name :start (1+ slash-i)))
(colon-i (or (position #\: name :start (1+ slash-i))
(error "No \":\" character in display name.")))
(decnet-colon-p (eql (elt name (1+ colon-i)) #\:))
(host (subseq name (1+ slash-i) (if decnet-colon-p
(1+ colon-i)
colon-i)))
(dot-i (and colon-i (position #\. name :start colon-i)))
(display (when colon-i
(parse-integer name
:start (if decnet-colon-p
(+ colon-i 2)
(1+ colon-i))
:end dot-i)))
(screen (when dot-i
(parse-integer name :start (1+ dot-i))))
(protocol
(cond ((or (string= host "") (string-equal host "unix")) :local)
(decnet-colon-p :decnet)
((> slash-i -1) (intern
(string-upcase (subseq name 0 slash-i))
:keyword))
(t :internet))))
(list host (or display 0) (or screen 0) protocol)))
(display-i (if decnet-colon-p
(1+ colon-i)
colon-i))
(dot-i (position #\. name :start colon-i))
(host (subseq name (1+ slash-i) display-i))
(display (parse-integer name :start (1+ display-i) :end dot-i))
(screen (if dot-i
(parse-integer name :start (1+ dot-i))
0))
(protocol (cond (decnet-colon-p
:decnet)
((> slash-i -1)
(intern (string-upcase (subseq name 0 slash-i))
:keyword))
(t
nil)))
(protocol (protocol-from-host host protocol)))
(list host display screen protocol)))


;;-----------------------------------------------------------------------------
Expand Down
Loading