Skip to content


Subversion checkout URL

You can clone with
Download ZIP
Browse files

Implemented UNIX connection type (local or abstract sockets).

(dbus-connect) should now "just work" to connect to the session bus
for unix connections. This should cover normal desktop usage. Except
that you cannot yet send or receive any messages over the bus.

I also removed most of the debug output to make it look more
professional. ;-)
  • Loading branch information...
commit 82f6db4a122bc693490f0269dd15956db2c09bd4 1 parent 6158706
@blitz authored
4 cl-dbus.asd
@@ -3,10 +3,12 @@
(defsystem cl-dbus
:components ((:file "packages")
(:file "transport" :depends-on ("packages"))
+ (:file "unix-transport" :depends-on ("packages" "transport"))
(:file "utilities" :depends-on ("packages"))
(:file "cookie-sha1-auth" :depends-on ("packages" "utilities"))
(:file "anonymous-auth" :depends-on ("packages" "utilities"))
- (:file "network" :depends-on ("packages" "cookie-sha1-auth" "anonymous-auth")))
+ (:file "network" :depends-on ("packages" "cookie-sha1-auth" "anonymous-auth"
+ "transport")))
:depends-on (iterate flexi-streams defclass-star usocket cl-ppcre
1  cookie-sha1-auth.lisp
@@ -46,7 +46,6 @@ epoch and the cookie itself (as string of hex digits)."
(destructuring-bind (context secret-cookie-id-str hex-challenge-str)
(cl-ppcre:split "\\s" (sb-ext:octets-to-string (parse-hex-string data)
:external-format :ascii))
- (format t "Got: ~A ~A ~A~%" context secret-cookie-id-str hex-challenge-str)
(let ((secret-cookie-id (parse-integer secret-cookie-id-str)))
;; Try to find the requested cookie.
(let ((cookie-data-str (block data
15 network.lisp
@@ -17,11 +17,15 @@
-(defun dbus-connect (host port)
- "Returns an connection to the given `host' and `port'"
+(defun dbus-connect (&optional (address :session))
+ "Returns a DBUS connection to the given ADDRESS. ADDRESS is either a
+symbol (:SESSION or :SYSTEM) or a string containing a DBUS
+address. Defaults to :SESSION."
(let* ((success nil)
- (stream (usocket:socket-stream (usocket:socket-connect
- host port :element-type '(unsigned-byte 8))))
+ (stream (etypecase address
+ (symbol (ecase address
+ (:session (connect-via-address-string (sb-posix:getenv "DBUS_SESSION_BUS_ADDRESS")))))
+ (string address)))
(con (make-instance 'dbus-connection
:stream stream)))
@@ -37,7 +41,6 @@
;; Check which authentication methods are accepted and try the
;; ones we support.
(let ((methods (accepted-methods ascii-stream)))
- (format t "Server supports authentication via:~{ ~A~}~%" methods)
(or (when (find "DBUS_COOKIE_SHA1" methods :test #'string=)
(try-cookie-sha1-auth ascii-stream))
(when (find "ANONYMOUS" methods :test #'string=)
@@ -49,6 +52,8 @@
(unless success
(dbus-close con)))))
+;;; Method calls
(defvar *endianness* :little-endian)
(defun read-uint32 (buf index)
47 transport.lisp
@@ -12,11 +12,12 @@
(defun server-address-value (address key)
- (gethash key (server-address-values address)))
+ (cdr (find key (server-address-values address) :key #'car :test #'string=)))
(defun unescape (string)
"String is an ASCII string with every non-ASCII (and some other)
-chars escaped by URI-style %XX sequences, with XX being hex-digits."
+chars escaped by URI-style %XX sequences, with XX being
+hex-digits. Returns the unescaped string."
(with-input-from-string (in string)
(iter (with output = (make-array 0
:element-type '(unsigned-byte 8)
@@ -35,6 +36,9 @@ chars escaped by URI-style %XX sequences, with XX being hex-digits."
(finally (return (sb-ext:octets-to-string output :external-format :utf8))))))
(defun parse-key-value-string (kv-string)
+ "Parse a DBUS address key-value pair (foo=bar) taking care of the
+strange escaping rules described in the standard. Returns a cons of
+two strings."
(iter (for part in (split "," kv-string))
(multiple-value-bind (match? matches)
(cl-ppcre:scan-to-strings "^([^=]+)=([^=]*)$" part)
@@ -44,6 +48,8 @@ chars escaped by URI-style %XX sequences, with XX being hex-digits."
(unescape (aref matches 1)))))))
(defun server-address-from-string (string)
+ "Parse a single server address and return a corresponding
+SERVER-ADDRES structure."
(multiple-value-bind (match? matches)
(cl-ppcre:scan-to-strings "^([^:]+):(.*)$" string)
(unless match?
@@ -52,10 +58,41 @@ chars escaped by URI-style %XX sequences, with XX being hex-digits."
:values (parse-key-value-string (aref matches 1)))))
(defun parse-server-address-list (string)
- (mapcar #'server-address-from-string
- (split ";" string)))
+ "Parse a string as given in the environment variable
+DBUS_SESSION_BUS_ADDRESS which can be a list of several server
+addresses. Returns a list of SERVER-ADDRESS structures."
+ (mapcar #'server-address-from-string (split ";" string)))
+;;; Run-time selection of transports
(defvar *transports* nil
- "List of fu")
+ "List of supported transports.")
+(defun register-transport (name fn)
+ (setf *transports* (cons (cons name fn)
+ (remove name *transports* :key #'car :test #'string=))))
+(defmacro deftransport (name (address) &body body)
+ "Register a transport for NAME. ADDRESS is the name of a
+ SERVER-ADDRESS structure. BODY should be code that takes the
+ SERVER-ADDRESS and returns a stream or NIL."
+ `(register-transport ,(etypecase
+ name
+ (symbol (string-downcase (string name)))
+ (string name))
+ (lambda (,address)
+ ,@body)))
+;;; Now finally the function that wraps all of this.
+(defun connect-via-address-string (string)
+ "Takes a string containing a DBUS server address (or multiple) and
+ returns a stream to the bus."
+ (iter (for address in (parse-server-address-list string))
+ (for transport-connector = (find (server-address-type address) *transports*
+ :key #'car :test #'string=))
+ (if transport-connector
+ (thereis (funcall (cdr transport-connector) address))
+ (warn "Unknown connection type: ~A" (server-address-type address)))))
;;; EOF
28 unix-transport.lisp
@@ -0,0 +1,28 @@
+;;; -*- Mode: Lisp -*-
+;;; Copyright (c) 2008 Julian Stecklina
+;;; This file is part of CL-DBUS. Look into LICENSE for license terms.
+(in-package :blitz.desktop.dbus)
+;;; TODO Extend usocket to support abstract sockets and rewrite this
+;;; to use usocket.
+#+(and sbcl linux)
+(deftransport unix (address)
+ (handler-case
+ (let ((abstract (server-address-value address "abstract"))
+ (path (server-address-value address "path")))
+ (let ((socket (make-instance (if abstract
+ 'sb-bsd-sockets:local-abstract-socket
+ 'sb-bsd-sockets:local-socket)
+ :type :stream)))
+ (sb-bsd-sockets:socket-connect socket (or abstract path))
+ (sb-bsd-sockets:socket-make-stream socket
+ :element-type '(unsigned-byte 8)
+ :input t
+ :output t)))
+ (sb-bsd-sockets:socket-error (c)
+ (warn "Unable to connect to dbus via unix transport, because of ~A." c)
+ nil)))
+;;; EOF
1  utilities.lisp
@@ -15,7 +15,6 @@
(subseq line 0 (1- (length line)))))
(defun format-crlf (stream fmt &rest args)
- (format t "~?~%" fmt args)
(format stream "~?~C~C" fmt args #\Return #\Newline))
(defun octets-to-hex-string (octets)
Please sign in to comment.
Something went wrong with that request. Please try again.