XMPP Backplane Server
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

134 lines
4.7 KiB

;;;; backplane-server.lisp
(in-package #:backplane-server)
;; request
(defclass request ()
((sender :initarg :sender)
(msg-id :initarg :msg-id
:reader msg-id)))
(defclass unknown-request (request)
((request :initarg :request
:reader request)))
(defclass result ()
((message :initarg :message)
(msg-id :initarg :msg-id
:reader msg-id)))
;; result
(defclass result/success (result) ())
(defclass result/error (result) ())
(defun error-p (obj) (typep obj (find-class 'result/error)))
(defun success-p (obj) (typep obj (find-class 'result/success)))
(defun make-success (&key msg msg-id)
(make-instance 'result/success
:message msg
:msg-id msg-id))
(defun make-error (&key msg msg-id)
(make-instance 'result/error
:message msg
:msg-id msg-id))
(defgeneric render-result (result))
(defmethod render-result ((res result/success))
(with-slots (message msg-id) res
`((STATUS . "OK")
(MESSAGE . ,message)
(MSGID . ,msg-id)))))
(defmethod render-result ((res result/error))
(with-slots (message msg-id) res
(MESSAGE . ,message)
(MSGID . ,msg-id)))))
(defgeneric parse-message (sender service api-version message msg-id)
(:documentation "Given an incoming message, turn it into the appropriate request."))
(defmethod parse-message (sender service api-version message msg-id)
(make-error :msg (format nil "unsupported service: ~A" service)
:msg-id msg-id))
(defun decode-message (message-str)
(cl-json:decode-json-from-string message-str)
(json:json-syntax-error (err)
(declare (ignorable err))
(make-error :msg (format nil "invalid json string: ~A" message-str)))))
(defun symbolize (str) (-> str string-upcase (intern :KEYWORD)))
(defun dispatch-parse-message (message sender)
(if-let ((api-version (cdr (assoc :VERSION message)))
(service (symbolize (cdr (assoc :SERVICE message))))
(msg-id (cdr (assoc :MSGID message))))
(parse-message sender service api-version (cdr (assoc :PAYLOAD message)) msg-id)
(make-error :msg (format nil "missing api_version, msgid, or service name in request in message")
:msg-id msg-id)))
(defgeneric handle-message (message)
(:documentation "Perform necessary actions to handle a backplane message, and return a result."))
(defmethod handle-message ((message unknown-request))
(make-error :msg (format nil "unknown request: ~A" (request message))
:msg-id (msg-id message)))
(defmacro success-> (init &rest forms)
(let ((blocksym (gensym)))
(flet ((maybe-call (f arg args)
`(let ((result ,arg))
(if (error-p result)
(return-from ,blocksym result)
(funcall (function ,f) result ,@args)))))
`(block ,blocksym
,(reduce (lambda (acc next)
(if (listp next)
(maybe-call (car next) acc (cdr next))
(maybe-call next acc '())))
:initial-value init)))))
(defmethod xmpp:handle ((conn xmpp:connection) (message xmpp:message))
(let ((sender (xmpp:from message)))
(format *standard-output* "message received from ~A" sender)
(xmpp:message conn
(xmpp:from message)
(success-> message
(dispatch-parse-message sender)
(error (e)
(format *error-output* "failed handling message from ~A: ~A"
sender e)
(make-error :msg "an unknown error occurred handling request")))))))
(let ((backplane nil))
(defun backplane-connect (xmpp-host xmpp-username xmpp-password)
(if backplane
(progn (setf backplane (xmpp:connect-tls :hostname xmpp-host))
(xmpp:auth backplane
(format nil "backplane-~A" (machine-instance))
:mechanism :sasl-plain)
;; (defmacro with-backplane (backplane &rest ops)
;; (let ((bp-sym (gensym)))
;; `(let ((,bp-sym ,backplane))
;; (unwind-protect (progn ,@ops)
;; (cl-xmpp:disconnect ,bp-sym)))))