diff --git a/backplane-dns.asd b/backplane-dns.asd index 6830640..8d1ec99 100644 --- a/backplane-dns.asd +++ b/backplane-dns.asd @@ -8,14 +8,10 @@ :serial t :depends-on (:alexandria :arrows - :cl-json - :cl-postgres + :backplane-server :cl-ppcre - :cl+ssl - :cl-xmpp - :cl-xmpp-tls + :ip-utils :postmodern :trivia) :components ((:file "package") - (:file "backplane-dns") - (:file "backplane-server"))) + (:file "backplane-dns"))) diff --git a/backplane-dns.lisp b/backplane-dns.lisp index 940820b..6716143 100644 --- a/backplane-dns.lisp +++ b/backplane-dns.lisp @@ -10,6 +10,8 @@ (uiop:die 1 "unable to find required env var: ~A" env-var)) value))) +(defun symbolize (str) (-> str string-upcase (intern :KEYWORD))) + (defclass dns-record () ((id :col-type integer :col-identity t @@ -66,76 +68,22 @@ (defparameter *hostname-rx* "(([a-zA-Z0-9]|[a-zA-Z0-9][a-zA-Z0-9\-]*[a-zA-Z0-9])\.)*([A-Za-z0-9]|[A-Za-z0-9][A-Za-z0-9\-]*[A-Za-z0-9])") -(defun ipv4-elements (str) - (handler-case - (mapcar #'parse-integer (split-string str #\.)) - (sb-int:simple-parse-error (_) - (declare (ignorable _)) nil))) - -(defun ipv4-p (str) - (let ((iplst (ipv4-elements str))) - (and (= (length iplst) 4) - (every (lambda (n) (<= 0 n 255)) - iplst)))) - -(defun ipv4 (str) - (if (not (ipv4-p str)) - nil - (let ((els (ipv4-elements str))) - (loop for el in (reverse els) - for i from 0 to (length els) - sum (ash el (* i 8)) into total - finally (return total))))) - -(defun ipv6-elements (str) - (flet ((split-bytes (str) (split-string str #\:)) - (parse-hex (str) (if (equal str "") 0 (parse-integer str :radix 16)))) - (let ((parts (mapcar #'split-bytes (cl-ppcre:split "::" - (cl-ppcre:regex-replace "::$" - str - "::0"))))) - (trivia:match parts - ((list only) (mapcar #'parse-hex only)) - ((list first last) (let ((middle (make-list - (- 8 (length first) - (length last)) - :initial-element "0"))) - (mapcar #'parse-hex (append first middle last)))) - (_ nil))))) - -(defun ipv6 (str) - (let ((els (ipv6-elements str))) - (if (/= 8 (length els)) - nil - (loop for el in (reverse els) - for i from 0 to (length els) - sum (ash el (* i 16)) into total - finally (return total))))) - -(defun ipv6-p (str) - (handler-case - (ipv6 str) - (sb-int:simple-parse-error (e) - (declare (ignorable e)) - nil))) - (defun get-domain (name) (car (select-dao 'dns-domain (:= 'name name)))) -(define-condition domain-name-missing (error) +(define-condition backplane-dns-error (error) ()) + +(define-condition domain-name-missing (backplane-dns-error) ((missing-domain :initarg :domain :reader missing-domain))) -(define-condition invalid-ip (error) - ((ip :initarg :ip))) - -(define-condition invalid-ipv4 (invalid-ip) ()) - -(define-condition invalid-ipv6 (invalid-ip) ()) - -(define-condition invalid-sshfp (error) +(define-condition invalid-sshfp (backplane-dns-error) ((sshfp :initarg :sshfp :reader sshfp))) +(define-condition invalid-ip (backplane-dns-error) + ((ip :initarg :ip + :reader ip))) + (defun find-host-records-by-type (host domain type) (if-let ((domain-id (some-> domain (get-domain) @@ -332,7 +280,7 @@ (let ((postmodern:*ignore-unknown-columns* t) (cl-postgres:*query-log* *standard-output*)) (postmodern:with-connection (list db-name db-username db-password db-host) - (let ((backplane (backplane-connect xmpp-host xmpp-username xmpp-password))) + (with-backplane (backplane (backplane-connect xmpp-host xmpp-username xmpp-password)) (xmpp:receive-stanza-loop backplane))))) (defun read-file-line (filename) diff --git a/backplane-server.lisp b/backplane-server.lisp deleted file mode 100644 index 39ad981..0000000 --- a/backplane-server.lisp +++ /dev/null @@ -1,135 +0,0 @@ -;;;; 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 - (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)))) - - ;;;; nope...capture the var name and make sure it gets closed, but still pass it in -(defmacro with-backplane (backplane &rest ops) - (let ((bp-sym (gensym))) - `(let ((,bp-sym ,backplane)) - (unwind-protect (progn ,@ops) - (cl-xmpp:disconnect ,bp-sym))))) diff --git a/package.lisp b/package.lisp index 3897d86..eb0743d 100644 --- a/package.lisp +++ b/package.lisp @@ -2,11 +2,20 @@ (defpackage #:backplane-dns (:use #:cl) + (:import-from #:arrows #:-> #:some->) (:import-from #:alexandria #:if-let) + (:import-from #:backplane-server + #:make-error + #:make-success + #:backplane-connect + #:with-backplane) + (:import-from #:ip-utils + #:ipv4-p + #:ipv6-p) (:import-from #:postmodern #:get-dao #:select-dao @@ -14,8 +23,6 @@ #:insert-dao #:delete-dao #:with-transaction) - (:import-from #:cl-json - #:decode-json-from-string - #:encode-json) + (:export #:start-listener-with-env #:backplane-dns-listen))