lsp-dbus-connection.lsp

   1 ;; This newlisp module implements dbus socket connection
   2 ;;
   3
   4 ; Require the FOOP context
   5 (unless (context? MAIN:FOOP) (load "foop.lsp"))
   6
   7 (context 'MAIN:DbusConnection)
   8 (FOOP path socket name serial)
   9
  10 (define (DbusConnection:DbusConnection PATH)
  11   (list (context) PATH -1 nil 0))
  12
  13 ;; Increment the serial and return it.
  14 (define (serial++)
  15   (!serial (+ 1 (%serial))))
  16
  17 ;; (open-socket)
  18 ; Internal utility method to re-open the %path socket and set the
  19 ; %socket field.
  20 (define (open-socket)
  21   (when (>= (%socket))
  22     (close (%socket))
  23     (!socket -1))
  24   (!socket (net-connect (%path))))
  25
  26 ;** Commands from client to server
  27 ; AUTH [mechanism] [initial-response]
  28 ; CANCEL
  29 ; BEGIN
  30 ; DATA <data in hex encoding>
  31 ; ERROR [human-readable error explanation]
  32 ; NEGOTIATE_UNIX_FD
  33
  34 ;** Commands from server to client
  35 ; REJECTED <space-separated list of mechanism names>
  36 ; OK <GUID in hex>
  37 ; DATA <data in hex encoding>
  38 ; ERROR [human-readable error explanation]
  39 ; AGREE_UNIX_FD
  40
  41 (define (read-message)
  42   (let ((BUFFER "") (RESULT ""))
  43     (while (and RESULT (net-select (%socket) "r" 1000))
  44       (if (net-receive (%socket) BUFFER 8192)
  45           (extend RESULT BUFFER)
  46         (begin
  47           (setf RESULT nil)
  48           (die 1 "dbus socket closed"))
  49         ))
  50     RESULT))
  51
  52 ;; (handshake MSG PAT)
  53 ; Perform a socket handshake sending MSG and return the result, or if
  54 ; PAT not nil, then return (regex PAT RESULT 0),
  55 (define (handshake MSG PAT)
  56   (let ((RESULT ""))
  57     (net-send (%socket) MSG)
  58     (setf RESULT (read-message))
  59     (if PAT (regex PAT RESULT 0) RESULT)))
  60
  61 (constant
  62  'AUTHFMT "AUTH EXTERNAL %s\r\n"
  63  'AUTHACK "OK (\\S+)\r\n"
  64  'KEEPFMT "NEGOTIATE_UNIX_FD\r\n"
  65  'KEEPACK "AGREE_UNIX_FD\r\n"
  66  )
  67
  68 ;; (initialize USER)
  69 ; Perform socket initialization sequence and return the name, or nil.
  70 (define (initialize (USER (env "USER")))
  71   (when (and (>= (open-socket))
  72              (net-send (%socket) (char 0))
  73              (handshake (format AUTHFMT (char2hex USER)) AUTHACK)
  74              (!name $1)
  75              (handshake KEEPFMT KEEPACK))
  76     (handshake "BEGIN\r\n")
  77     (%name)))
  78
  79 (define (cancel)
  80   (handshake "CANCEL\r\n" "(.*)"))
  81
  82 "lsp-dbus-connection.lsp"