85 lines
2.6 KiB
Common Lisp
85 lines
2.6 KiB
Common Lisp
|
;;;; backplane-server.lisp
|
||
|
|
|
||
|
|
(in-package #:backplane-dns)
|
||
|
|
|
||
|
|
;; request
|
||
|
|
|
||
|
|
(defclass request ()
|
||
|
|
((sender :initarg :sender)))
|
||
|
|
|
||
|
|
(defclass unknown-request (request)
|
||
|
|
((request :initarg :request
|
||
|
|
:reader request)))
|
||
|
|
|
||
|
|
(defclass result ()
|
||
|
|
((message :initarg :message)))
|
||
|
|
|
||
|
|
;; result
|
||
|
|
|
||
|
|
(defclass result/success (result) ())
|
||
|
|
(defclass result/error (result) ())
|
||
|
|
|
||
|
|
(defun make-success (&optional msg)
|
||
|
|
(make-instance 'result/success :message msg))
|
||
|
|
|
||
|
|
(defun make-error (&optional msg)
|
||
|
|
(make-instance 'result/error :message msg))
|
||
|
|
|
||
|
|
(defgeneric render-result (result))
|
||
|
|
|
||
|
|
(defmethod render-result ((res result/success))
|
||
|
|
(with-slots (message) res
|
||
|
|
(if message
|
||
|
|
(format nil "OK: ~A" message)
|
||
|
|
"OK")))
|
||
|
|
|
||
|
|
(defmethod render-result ((res result/error))
|
||
|
|
(with-slots (message) res
|
||
|
|
(if message
|
||
|
|
(format nil "ERROR: ~A" message)
|
||
|
|
"ERROR")))
|
||
|
|
|
||
|
|
(defgeneric parse-message (sender service api-version message)
|
||
|
|
(:documentation "Given an incoming message, turn it into the appropriate request."))
|
||
|
|
|
||
|
|
(defmethod parse-message (sender service api-version message)
|
||
|
|
(make-error "unsupported request"))
|
||
|
|
|
||
|
|
(defun decode-message (message-str)
|
||
|
|
(cl-json:decode-json-from-string message-str))
|
||
|
|
|
||
|
|
(defun dispatch-parse-message (message sender)
|
||
|
|
(if-let ((api-version (cdr (assoc :API-VERSION message)))
|
||
|
|
(service (cdr (assoc :SERVICE message))))
|
||
|
|
(parse-message sender service api-version (assoc :PAYLOAD message))
|
||
|
|
(make-error (format nil "missing api-version or service name in request"))))
|
||
|
|
|
||
|
|
(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 (format nil "unknown request: ~A" (request message))))
|
||
|
|
|
||
|
|
(defmethod xmpp:handle ((conn xmpp:connection) (message xmpp:message))
|
||
|
|
(let ((sender (xmpp:from message)))
|
||
|
|
(xmpp:message conn
|
||
|
|
(xmpp:from message)
|
||
|
|
(-> message
|
||
|
|
(xmpp:body)
|
||
|
|
(decode-message)
|
||
|
|
(dispatch-parse-message sender)
|
||
|
|
(handle-message)
|
||
|
|
(render-result)))))
|
||
|
|
|
||
|
|
(let ((backplane nil))
|
||
|
|
(defun backplane-connect (xmpp-host xmpp-username xmpp-password)
|
||
|
|
(if backplane
|
||
|
|
backplane
|
||
|
|
(progn (setf backplane (xmpp:connect-tls :hostname xmpp-host))
|
||
|
|
(xmpp:auth backplane
|
||
|
|
xmpp-username
|
||
|
|
xmpp-password
|
||
|
|
(format nil "backplane-~A" (machine-instance))
|
||
|
|
:mechanism :sasl-plain)
|
||
|
|
backplane))))
|