Initial commit

.gitignore

@@ -0,0 +1 @@
+*.fasl

README.md

@@ -0,0 +1,4 @@
+# backplane-server
+### _Niten <niten@fudo.org>_
+
+A simple server that will connect to XMPP and listen for incoming messages.

backplane-server.asd

@@ -0,0 +1,14 @@
+;;;; backplane-server.asd
+
+(asdf:defsystem #:backplane-server
+  :description "XMPP Backplane Server"
+  :author "Niten <niten@fudo.org>"
+  :version "0.1.0"
+  :serial t
+  :depends-on (:alexandria
+               :arrows
+               :cl-json
+               :cl-xmpp
+               :cl-xmpp-tls)
+  :components ((:file "package")
+               (:file "backplane-server")))

backplane-server.lisp

@@ -0,0 +1,134 @@
+;;;; 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 (backplane &rest ops)
+;;   (let ((bp-sym (gensym)))
+;;     `(let ((,bp-sym ,backplane))
+;;        (unwind-protect (progn ,@ops)
+;;          (cl-xmpp:disconnect ,bp-sym)))))

package.lisp

@@ -0,0 +1,20 @@
+;;;; package.lisp
+
+(defpackage #:backplane-server
+  (:use #:cl)
+  (:import-from #:arrows
+                #:->
+                #:some->)
+  (:import-from #:alexandria
+                #:if-let)
+  (:import-from #:cl-json
+                #:decode-json-from-string
+                #:encode-json-to-string)
+
+  (:export      #:make-success
+                #:make-error
+                #:success-p
+                #:error-p
+                #:parse-message
+                #:handle-message
+                #:backplane-connect))