backplane-server/backplane-server.lisp

;;;; 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
    (cl-json:encode-json-to-string
     `((STATUS  . "OK")
       (MESSAGE . ,message)
       (MSGID   . ,msg-id)))))

(defmethod render-result ((res result/error))
  (with-slots (message msg-id) res
    (cl-json:encode-json-to-string
     `((STATUS  . "ERROR")
       (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)
  (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
                   (handler-case
                       (success-> message
                                  (xmpp:body)
                                  (decode-message)
                                  (dispatch-parse-message sender)
                                  (handle-message))
                     (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
        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))))

(defmacro with-backplane (bp-clause &rest ops)
  (when (or (not (listp bp-clause))
            (not (= 2 (length bp-clause)))
            (not (symbolp (car bp-clause))))
    (error "bad backplane clause"))
  (let ((bp-name (car bp-clause)))
    `(let ((,bp-name ,(cadr bp-clause)))
       (unwind-protect
            (progn ,@ops)
         (cl-xmpp:disconnect ,bp-name)))))