;;; An example DBus service in Lisp
(require :asdf)
(require :cffi)
(import 'cffi:foreign-alloc)
(import 'cffi:foreign-free)
(import 'cffi:null-pointer-p)
(import 'cffi:foreign-slot-value)
(import 'cffi:foreign-string-to-lisp)
(import 'cffi:lisp-string-to-foreign)
(import 'cffi:foreign-string-alloc)
(import 'cffi:mem-ref)
(import 'cffi:null-pointer)

(require :dbus)
(use-package :libdbus)

; Utility function
(defun sysquit (status)
  #+sbcl (sb-ext:quit :unix-status status)
  ;#+lispworks (lw:quit :status status)
  (error "Don't know how to quit")
)

(defun die (msg)
  "Exit after printing a given message"
  (format *error-output* msg)
  (sysquit 1))

; Initialize the error struct
(defvar *error* (foreign-alloc 'dbus-error))
(dbus-error-init *error*)

; Open a session bus connection
(defvar *connection* (dbus-bus-get :DBUS_BUS_SESSION *error*))
(if (or (null-pointer-p *connection*) (dbus-error-is-set *error*))
  (progn
    (format *error-output* "Failed to connect to session bus: ~A~%" (foreign-slot-value *error* 'dbus-error 'dbus::message))
    (dbus-error-free *error*)
    (foreign-free *error*)
    (sysquit 1)))
    
; Request a name
(let ((ret (dbus-bus-request-name *connection* "net.coderanger.DBusLisp" +dbus-name-flag-replace-existing+ *error*)))
   (cond
     ((dbus-error-is-set *error*) (format *error-output* "Error: ~A~%" (foreign-slot-value *error* 'dbus-error 'dbus::message))
                                  (dbus-error-free *error*)
                                  (foreign-free *error*)
                                  (sysquit 1))
     ((/= ret +dbus-request-name-reply-primary-owner+) (format *error-output* "Unable to get name~%")
                                                       (dbus-error-free *error*)
                                                       (foreign-free *error*)
                                                       (sysquit 1))
     ))
     
; Loop, looking for new messages
(loop do
  ;pump DBus - read what needs to be read, write what needs to be written
  (dbus-connection-read-write *connection* 0)
  (let ((msg (dbus-connection-pop-message *connection*)))
    (if (null-pointer-p msg) (sleep 2)
      (progn
        (format *standard-output* "Got a message ~A ~A~%" (dbus-message-get-interface msg) (dbus-message-get-member msg))
        (if (dbus-message-is-method-call msg "net.coderanger.DBusLisp" "Method")
          (let ((args (foreign-alloc :pointer)) (param (foreign-alloc :pointer)))
            (cond
              ((not (dbus-message-iter-init msg args)) (die "No message arguments~%"))
              ((/= (char-int #\s) (dbus-message-iter-get-arg-type args)) (die "Argument not a string~%"))
              (t (dbus-message-iter-get-basic args param)))
            (let* ((reply (dbus-message-new-method-return msg))
                   (reply-param (format nil "Hello ~A" (foreign-string-to-lisp (mem-ref param :pointer))))
                   (reply-param-buf (foreign-string-alloc reply-param)))
              ;(dbus-message-iter-init-append reply args)
              (setf (mem-ref param :pointer) reply-param-buf)
              ;(dbus-message-iter-append-basic args (char-int #\s) param)
              (dbus-message-append-args reply +dbus-type-string+ :pointer param :int +dbus-type-invalid+)

              (dbus-connection-send *connection* reply (null-pointer))
              (dbus-connection-flush *connection*)
              (dbus-message-unref reply)
            )
          )
        )
        (dbus-message-unref msg)
      )
    )
  )
)