backplane-dns/backplane-server.lisp

;;;; backplane-server.lisp

(in-package #:backplane-dns)

;; 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
    (let ((msg   (if message (format nil ":~A" message) ""))
          (msgid (if msg-id (format nil " (~A)" msg-id) "")))
      (format nil "OK~A~A" msgid msg))))

(defmethod render-result ((res result/error))
  (with-slots (message msg-id) res
    (let ((msg   (if message (format nil ":~A" message) ""))
          (msgid (if msg-id (format nil " (~A)" msg-id) "")))
      (format nil "ERROR~A~A" msgid msg))))

(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)
  (handler-case
      (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 '())))
                  forms
                  :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)
                  (render-result (success-> message
                                            (xmpp:body)
                                            (decode-message)
                                            (dispatch-parse-message sender)
                                            (handle-message))))))

(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))))