lsp-dbus/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 (net-select (%socket) "r" 1000)
  44       (net-receive (%socket) BUFFER 8192)
  45       (extend RESULT BUFFER))
  46     RESULT))
  47
  48 ;; (handshake MSG PAT)
  49 ; Perform a socket handshake sending MSG and return the result, or if
  50 ; PAT not nil, then return (regex PAT RESULT 0),
  51 (define (handshake MSG PAT)
  52   (let ((RESULT ""))
  53     (net-send (%socket) MSG)
  54     (setf RESULT (read-message))
  55     (if PAT (regex PAT RESULT 0) RESULT)))
  56
  57 (define (char2hex STR)
  58   (join (map (curry format "%2x") (map char (explode STR)))))
  59
  60 (constant
  61  'AUTHFMT "AUTH EXTERNAL %s\r\n"
  62  'AUTHACK "OK (\\S+)\r\n"
  63  'KEEPFMT "NEGOTIATE_UNIX_FD\r\n"
  64  'KEEPACK "AGREE_UNIX_FD\r\n"
  65  )
  66
  67 ;; (initialize USER)
  68 ; Perform socket initialization sequence and return the name, or nil.
  69 (define (initialize (USER (env "USER")))
  70   (when (and (>= (open-socket))
  71              (net-send (%socket) (char 0))
  72              (handshake (format AUTHFMT (char2hex USER)) AUTHACK)
  73              (!name $1)
  74              (handshake KEEPFMT KEEPACK))
  75     (handshake "BEGIN\r\n")
  76     (%name)))
  77
  78 (define (cancel)
  79   (handshake "CANCEL\r\n" "(.*)"))
  80
  81 "DbusConnection"
  82