Properly depend on backplane-server and ip-utils
This commit is contained in:
parent
c552394e55
commit
d9e13bae16
|
|
@ -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")))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
13
package.lisp
13
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))
|
||||
|
|
|
|||
Loading…
Reference in New Issue