;; This newlisp module implements dbus socket connection
;;

; Require the FOOP context
(unless (context? MAIN:FOOP) (load "foop.lsp"))

(context 'MAIN:DbusConnection)
(FOOP path socket name serial)

(define (DbusConnection:DbusConnection PATH)
  (list (context) PATH -1 nil 0))

;; Increment the serial and return it.
(define (serial++)
  (!serial (+ 1 (%serial))))

;; (open-socket)
; Internal utility method to re-open the %path socket and set the
; %socket field.
(define (open-socket)
  (when (>= (%socket))
    (close (%socket))
    (!socket -1))
  (!socket (net-connect (%path))))

;** Commands from client to server
; AUTH [mechanism] [initial-response]
; CANCEL
; BEGIN
; DATA <data in hex encoding>
; ERROR [human-readable error explanation]
; NEGOTIATE_UNIX_FD

;** Commands from server to client
; REJECTED <space-separated list of mechanism names>
; OK <GUID in hex>
; DATA <data in hex encoding>
; ERROR [human-readable error explanation]
; AGREE_UNIX_FD

(define (read-message)
  (let ((BUFFER "") (RESULT ""))
    (while (and RESULT (net-select (%socket) "r" 1000))
      (if (net-receive (%socket) BUFFER 8192)
          (extend RESULT BUFFER)
        (begin
          (setf RESULT nil)
          (die 1 "dbus socket closed"))
        ))
    RESULT))

;; (handshake MSG PAT)
; Perform a socket handshake sending MSG and return the result, or if
; PAT not nil, then return (regex PAT RESULT 0),
(define (handshake MSG PAT)
  (let ((RESULT ""))
    (net-send (%socket) MSG)
    (setf RESULT (read-message))
    (if PAT (regex PAT RESULT 0) RESULT)))

(constant
 'AUTHFMT "AUTH EXTERNAL %s\r\n"
 'AUTHACK "OK (\\S+)\r\n"
 'KEEPFMT "NEGOTIATE_UNIX_FD\r\n"
 'KEEPACK "AGREE_UNIX_FD\r\n"
 )

;; (initialize USER)
; Perform socket initialization sequence and return the name, or nil.
(define (initialize (USER (env "USER")))
  (when (and (>= (open-socket))
             (net-send (%socket) (char 0))
             (handshake (format AUTHFMT (char2hex USER)) AUTHACK)
             (!name $1)
             (handshake KEEPFMT KEEPACK))
    (handshake "BEGIN\r\n")
    (%name)))

(define (cancel)
  (handshake "CANCEL\r\n" "(.*)"))

"lsp-dbus-connection.lsp"