Skip to content
Browse files

Implemented parts of message marshalling.

The daemon rejects our Hello message... Don't know why...
  • Loading branch information...
1 parent 82f6db4 commit 656cd77440a1e5e2299128c86745a691516f904e @blitz committed
Showing with 236 additions and 18 deletions.
  1. +1 −1 dbus-test.conf
  2. +235 −17 network.lisp
View
2 dbus-test.conf
@@ -5,7 +5,7 @@
<!-- This is not an offical bus type... but we use it for development only. -->
<type>test</type>
- <listen>tcp:host=localhost,port=40102</listen>
+ <listen>unix:path=/tmp/dbus-test</listen>
<standard_session_servicedirs />
View
252 network.lisp
@@ -22,10 +22,11 @@
symbol (:SESSION or :SYSTEM) or a string containing a DBUS
address. Defaults to :SESSION."
(let* ((success nil)
- (stream (etypecase address
- (symbol (ecase address
- (:session (connect-via-address-string (sb-posix:getenv "DBUS_SESSION_BUS_ADDRESS")))))
- (string address)))
+ (stream (connect-via-address-string
+ (etypecase address
+ (symbol (ecase address
+ (:session (sb-posix:getenv "DBUS_SESSION_BUS_ADDRESS"))))
+ (string address))))
(con (make-instance 'dbus-connection
:stream stream)))
(unwind-protect
@@ -45,9 +46,16 @@ address. Defaults to :SESSION."
(try-cookie-sha1-auth ascii-stream))
(when (find "ANONYMOUS" methods :test #'string=)
(try-anonymous-auth ascii-stream))
- (error "Could not authenticate to server."))))
+ (error "Could not authenticate to server.")))
+ (format-crlf ascii-stream "BEGIN")
+ (force-output ascii-stream))
(setq success t)
con)
+ ;; XXX
+ ;; We need to call org.freedesktop.DBus.Hello after connecting to get
+ ;; a name on the bus. This method takes no arguments and returns a
+ ;; string.
+
;; Cleanup
(unless success
(dbus-close con)))))
@@ -55,22 +63,232 @@ address. Defaults to :SESSION."
;;; Method calls
(defvar *endianness* :little-endian)
+(defvar *byte-counter*)
+
+(defun dbus-read-alignment (stream alignment)
+ "Skip bytes to achieve an alignment of ALIGNMENT bytes."
+ (let ((mod (nth-value 1 (truncate *byte-counter* alignment))))
+ (unless (zerop mod)
+ (iter (repeat (- alignment mod))
+ (dbus-read-byte stream)))))
-(defun read-uint32 (buf index)
- (declare (type (simple-array (unsigned-byte 8) (*)) buf))
+(defun dbus-read-byte (stream)
+ (incf *byte-counter* 1)
+ (read-byte stream))
+
+(defun dbus-read-uint16 (stream)
+ (dbus-read-alignment stream 2)
+ (ecase *endianness*
+ (:little-endian
+ (logior (dbus-read-byte stream)
+ (ash (dbus-read-byte stream) 8)))
+ (:big-endian
+ (logior (ash (dbus-read-byte stream) 8)
+ (dbus-read-byte stream)))))
+
+(defun dbus-read-uint32 (stream)
+ (dbus-read-alignment stream 4)
(ecase *endianness*
(:little-endian
- (logior (aref buf index)
- (ash (aref buf (+ index 1)) 8)
- (ash (aref buf (+ index 2)) 16)
- (ash (aref buf (+ index 3)) 24)))
+ (logior (dbus-read-byte stream)
+ (ash (dbus-read-byte stream) 8)
+ (ash (dbus-read-byte stream) 16)
+ (ash (dbus-read-byte stream) 24)))
(:big-endian
- (logior (ash (aref buf index) 24)
- (ash (aref buf (+ index 1)) 16)
- (ash (aref buf (+ index 2)) 8)
- (aref buf (+ index 3))))))
+ (logior (ash (dbus-read-byte stream) 24)
+ (ash (dbus-read-byte stream) 16)
+ (ash (dbus-read-byte stream) 8)
+ (dbus-read-byte stream)))))
+
+(defun dbus-read-string (stream)
+ (let ((length (dbus-read-uint32 stream)))
+ (when (> length (* 10 1024 1024))
+ (cerror "This is okay. Continue." "Incredibly large string (~,2F MB) in DBUS request."
+ (/ length 1024 1024)))
+ (let* ((buf (make-array length :element-type '(unsigned-byte 8)))
+ (bytes (read-sequence buf stream)))
+ (assert (= bytes length))
+ (incf *byte-counter* bytes)
+ (assert (zerop (dbus-read-byte stream)))
+ (sb-ext:octets-to-string buf :external-format :utf8))))
+
+(defun dbus-read-signature (stream)
+ (let* ((length (dbus-read-byte stream))
+ (buf (make-array length :element-type '(unsigned-byte 8)))
+ (bytes (read-sequence buf stream)))
+ (assert (= length bytes))
+ (assert (zerop (dbus-read-byte stream)))
+ (sb-ext:octets-to-string buf :external-format :utf8)))
+
+;;; Message type
+(defconstant +method-call+ 1)
+(defconstant +method-return+ 2)
+(defconstant +error+ 3)
+(defconstant +signal+ 4)
+
+;;; Header fields
+(defconstant +path+ 1)
+(defconstant +interface+ 2)
+(defconstant +member+ 3)
+(defconstant +error-name+ 4)
+(defconstant +reply-serial+ 5)
+(defconstant +destination+ 6)
+(defconstant +sender+ 7)
+(defconstant +signature+ 8)
+
+;;; Header flags
+(defconstant +no-reply-expected+ #x1)
+(defconstant +no-auto-start+ #x2)
+
+(defconstant +dbus-major-version+ 1)
+
+(defun dbus-write-byte (stream byte)
+ (declare (type (unsigned-byte 8) byte))
+ (incf *byte-counter*)
+ (write-byte byte stream))
+
+(defun dbus-write-alignment (stream alignment)
+ "Insert padding to achieve an alignment of ALIGNMENT bytes."
+ (let ((mod (nth-value 1 (truncate *byte-counter* alignment))))
+ (unless (zerop mod)
+ (format t "Emitting ~A byte(s) alignment.~%" (- alignment mod))
+ (iter (repeat (- alignment mod))
+ (dbus-write-byte stream 0)))))
+
+
+(defun dbus-write-uint32 (stream uint32)
+ (declare (type (unsigned-byte 32) uint32))
+ (format t "Emitting UINT32: #x~X~%" uint32)
+ (dbus-write-alignment stream 4)
+ (let ((buf (make-array 4 :element-type '(unsigned-byte 8))))
+ (declare (dynamic-extent buf))
+ (ecase *endianness*
+ (:little-endian
+ (setf (aref buf 0) (logand uint32 #xFF)
+ (aref buf 1) (logand (ash uint32 -8) #xFF)
+ (aref buf 2) (logand (ash uint32 -16) #xFF)
+ (aref buf 3) (logand (ash uint32 -24) #xFF)))
+ (:big-endian
+ (setf (aref buf 0) (logand (ash uint32 -24) #xFF)
+ (aref buf 1) (logand (ash uint32 -16) #xFF)
+ (aref buf 2) (logand (ash uint32 -8) #xFF)
+ (aref buf 3) (logand uint32 #xFF))))
+ (write-sequence buf stream)
+ (incf *byte-counter* 4)))
+
+(defun dbus-write-signature (stream sig)
+ (format t "Emitting signature: ~A~%" sig)
+ (let ((buf (sb-ext:string-to-octets sig)))
+ (dbus-write-byte stream (length buf))
+ (write-sequence buf stream)
+ (incf *byte-counter* (length buf))))
+
+(defun dbus-write-string (stream string)
+ (format t "Emitting string: ~A~%" string)
+ (let ((buf (sb-ext:string-to-octets string)))
+ (dbus-write-uint32 stream (length buf))
+ (write-sequence buf stream)
+ (incf *byte-counter* (length buf))))
+
+(defmacro dbus-with-array-write ((stream-var output-stream alignment) &body body)
+ (let ((out-var (gensym "OUT-VAR"))
+ (ali-var (gensym "ALI-VAR")))
+ `(let ((,out-var ,output-stream)
+ (,ali-var ,alignment)
+ (buf (flexi-streams:with-output-to-sequence (,stream-var)
+ (let ((*byte-counter* 0))
+ ,@body))))
+ (format t "BC before array = ~A~%" *byte-counter*)
+ (dbus-write-uint32 ,out-var (length buf))
+ (dbus-write-alignment stream ,ali-var)
+ (format t "Writing array body with ~A bytes.~%" (length buf))
+ (write-sequence buf ,out-var)
+ (incf *byte-counter* (length buf))
+ (format t "BC after array = ~A~%" *byte-counter*)
+ )))
+
+(defun dbus-marshal-to-buffer (signature arguments)
+ (flexi-streams:with-output-to-sequence (out)
+ (with-input-from-string (sig signature)
+ )
+ )
+ )
+
+
+; method call sender=:1.4 -> dest=org.freedesktop.DBus path=/org/freedesktop/DBus; interface=org.freedesktop.DBus; member=Hello
+
+
+(defun dbus-method-call (con &key path interface member signature arguments
+ destination
+ (serial 1)
+ (reply-expected t)
+ (auto-start t))
+ (assert (and member path))
+ (let ((stream (stream-of con))
+ (body (dbus-marshal-to-buffer signature arguments))
+ (*byte-counter* 0))
+ (dbus-write-byte stream (ecase *endianness*
+ (:little-endian (char-code #\l))
+ (:big-endian (char-code #\B))))
+ (dbus-write-byte stream +method-call+)
+ (dbus-write-byte stream (logior (if reply-expected 0 +no-reply-expected+)
+ (if auto-start 0 +no-auto-start+)))
+ (dbus-write-byte stream +dbus-major-version+)
+ (dbus-write-uint32 stream (length body))
+ (dbus-write-uint32 stream serial)
+ (assert (= *byte-counter* 12))
+ (dbus-with-array-write (array-stream stream 8)
+ ;; PATH
+ (format t "PATH (~A)~%" *byte-counter*)
+ (dbus-write-byte array-stream +path+)
+ (dbus-write-signature array-stream "o")
+ (dbus-write-string array-stream path)
+ ;; MEMBER
+ (format t "MEMBER~%")
+ (dbus-write-alignment array-stream 8)
+ (dbus-write-byte array-stream +member+)
+ (dbus-write-signature array-stream "s")
+ (dbus-write-string array-stream member)
+ ;; Interface
+ (when interface
+ (format t "INTERFACE~%")
+ (dbus-write-alignment array-stream 8)
+ (dbus-write-byte array-stream +interface+)
+ (dbus-write-signature array-stream "s")
+ (dbus-write-string array-stream interface))
+ (when destination
+ (format t "DESTINATION~%")
+ (dbus-write-alignment array-stream 8)
+ (dbus-write-byte array-stream +destination+)
+ (dbus-write-signature array-stream "s")
+ (dbus-write-string array-stream destination))
+ ;; SIGNATURE
+ (when (and signature (> (length signature) 0))
+ (format t "SIGNATURE~%")
+ (dbus-write-alignment array-stream 8)
+ (dbus-write-byte array-stream +signature+)
+ (dbus-write-signature array-stream "g")
+ (dbus-write-signature array-stream signature)))
+
+ (format t "BC = ~A~%" *byte-counter*)
+ (dbus-write-alignment stream 8)
+ (write-sequence body stream)
+ (force-output stream)))
+
+(defun try-to-send-hello ()
+ (let ((con (dbus-connect "unix:path=/tmp/dbus-test,guid=7ec02b0af9c2b6e23f10880449051a5a")))
+ (unwind-protect
+ (dbus-method-call con
+ :path "/org/freedesktop/DBus"
+ :destination "org.freedesktop.DBus"
+ :interface "org.freedesktop.DBus"
+ :member "Hello"
+ :signature ""
+ :arguments ())
+ (dbus-close con))))
+#+ ignore
(defun dbus-read-header (con)
(let ((buf (make-array 12 :element-type '(unsigned-byte 8))))
(assert (= 12 (read-sequence buf (stream-of con))))
@@ -80,8 +298,8 @@ address. Defaults to :SESSION."
(msg-type (aref buf 1))
(flags (aref buf 2))
(protocol-version (aref buf 3))
- (body-length (read-uint32 buf 4))
- (serial (read-uint32 buf 8)))
+ (body-length (dbus-read-uint32 buf 4))
+ (serial (dbus-read-uint32 buf 8)))
(assert (= protocol-version 1))
(list *endianness* msg-type flags protocol-version body-length serial))))

0 comments on commit 656cd77

Please sign in to comment.
Something went wrong with that request. Please try again.