Browse Source

Initial commit

master
Niten 2 years ago
commit
8b30811ab5
  1. 1
      .gitignore
  2. 4
      README.md
  3. 14
      backplane-server.asd
  4. 134
      backplane-server.lisp
  5. 20
      package.lisp

1
.gitignore

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

4
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.

14
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")))

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

20
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))
Loading…
Cancel
Save