backplane-dns/backplane-server.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 error-p (obj) (typep obj (find-class 'result/error)))
(defun success-p (obj) (typep obj (find-class 'result/success)))

(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 (format nil "unsupported service: ~A" service)))

(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 (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)))))
    (parse-message sender service api-version (cdr (assoc :PAYLOAD message)))
    (make-error (format nil "missing api_version or service name in request in message"))))

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

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