diff options
Diffstat (limited to 'lisp/entity')
| -rw-r--r-- | lisp/entity/dns-record.lisp | 168 | ||||
| -rw-r--r-- | lisp/entity/entity.lisp | 44 | ||||
| -rw-r--r-- | lisp/entity/generics.lisp | 51 |
3 files changed, 263 insertions, 0 deletions
diff --git a/lisp/entity/dns-record.lisp b/lisp/entity/dns-record.lisp new file mode 100644 index 0000000..7fa2f4a --- /dev/null +++ b/lisp/entity/dns-record.lisp @@ -0,0 +1,168 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:dns-admin) + +(defclass dns-record (entity) + ((*recordtype :initarg :*recordtype + :initform nil + :accessor *recordtype) + (name :initarg :name + :initform nil + :accessor name)) + (:documentation "Base class for DNS records.")) + +(defclass dns-record-infoblox (dns-record) + ((--ref :initarg :--ref + :initform nil + :accessor --ref) + (ttl :initarg :ttl + :initform nil + :accessor ttl)) + (:documentation "Base class for DNS records of type infoblox.")) + +(defclass dns-record-infoblox-a (dns-record-infoblox) + ((ipv-4-addr :initarg :ipv-4-addr + :initform nil + :accessor ipv-4-addr)) + (:documentation "DNS A record of type infoblox.")) + +(defclass dns-record-infoblox-aaaa (dns-record-infoblox) + ((ipv-6-addr :initarg :ipv-6-addr + :initform nil + :accessor ipv-6-addr)) + (:documentation "DNS AAAA record of type infoblox.")) + +(defclass dns-record-infoblox-cname (dns-record-infoblox) + ((canonical :initarg :canonical + :initform nil + :accessor canonical)) + (:documentation "DNS CNAME record of type infoblox.")) + +(defclass dns-record-infoblox-ptr (dns-record-infoblox) + ((ptrdname :initarg :ptrdname + :initform nil + :accessor ptrdname) + (ipv-4-addr :initarg :ipv-4-addr + :initform nil + :accessor ipv-4-addr)) + (:documentation "DNS PTR record of type infoblox.")) + +(defun sanitize-dns-filter-param (param) + (cond ((intersection `(,param) '("" "null" "undefined") :test 'string=) nil) + (t param))) + +(defmethod slot-to-param ((dns-record dns-record-infoblox) slot) + (cond ((eq slot '*recordtype) 'recordtype) + ((eq slot '--ref) 'ref) + ((eq slot 'ipv-4-addr) 'ipv4addr) + ((eq slot 'ipv-6-addr) 'ipv6addr) + (t slot))) + +(defmethod param-to-slot ((dns-record dns-record-infoblox) param) + (cond ((eq param 'recordtype) '*recordtype) + ((eq param 'ref) '--ref) + ((eq param 'ipv4addr) 'ipv-4-addr) + ((eq param 'ipv6addr) 'ipv-6-addr) + (t param))) + +(defmethod make-dns-record ((dns dns) recordtype) + (let* ((package (package-name #.*package*)) + (dns-record-class (intern (string-upcase (format nil "dns-record-~a-~a" (backend-type dns) recordtype)) (find-package package)))) + (make-instance dns-record-class :*recordtype recordtype))) + +(defmethod intersect-dns-record-function-args ((dns-record dns-record) func-symbol) + (intersection (sb-introspect:function-lambda-list func-symbol) + (mapcar (lambda (slot) + (slot-to-param dns-record slot)) + (map-slot-names dns-record)))) + +(defmethod search-filter-satisfied-p ((dns-record dns-record) rec) + (not (position nil (mapcar (lambda (slot) + (let ((slot-has-value-p (and (slot-value dns-record slot)))) + (or (not slot-has-value-p) + (and slot-has-value-p + (match-it (slot-value dns-record slot) (slot-value rec slot)))))) + (remove-if 'null (mapcar (lambda (s) + (when (slot-is-field-p s) s)) + (map-slot-names dns-record))))))) + +(defmacro define-dns-impl ((method-name action) &body macro-body) + ;; dig @127.0.0.1 +dnssec ckons.org AXFR + (let ((endpoint (gensym))) + `(progn + (defgeneric ,method-name (dns dns-record-infoblox)) + (defmethod ,method-name ((dns dns) (dns-record dns-record-infoblox)) + (let ((,endpoint (format nil + "~a/~a?_return_as_object=1~a" + (url dns) + (if (intersection `(,,action) '(:get :post)) + (format nil "record:~a" (*recordtype dns-record)) + (--ref dns-record)) + (if (and (eq (type-of dns-record) 'dns-record-infoblox-ptr) + (not (eq ,action :delete))) + "&_return_fields=name,ptrdname,ipv4addr,ipv6addr" + ""))) + (parameters (if (slot-value dns-record 'ttl) + `(("use_ttl" . t) ("ttl" . ,(ttl dns-record))) + (remove-if 'null (mapcar (lambda (slot) + (when (and (not (eq ,action :get)) + (not (eq slot '--ref)) + (slot-is-field-p slot) + (slot-value dns-record slot)) + `(,(string-downcase (symbol-name (slot-to-param dns-record slot))) . ,(slot-value dns-record slot)))) + (map-slot-names dns-record)))))) + (when (not (eq ,action :get)) + (setf parameters (alist-to-json parameters))) + (multiple-value-bind (body status-code headers uri stream must-close reason) + (apply #'drakma-request `(,,endpoint + nil + :method ,,action + ,@(when (not (eq ,action :get)) `(:content-type "application/json")) + ,@(if (eq ,action :get) + `(:parameters ,parameters) + `(:content ,parameters)) + :basic-authorization (,(session-value :username) ,(session-value :pwd)))) + (declare (ignore headers uri stream must-close reason)) + (cond ((or (= status-code 401) (= status-code 403)) + (hunchentoot:require-authorization (name *webapp*))) + ((< status-code 300) + ,@macro-body) + (t + (format nil "Error response from infoblox.~%Method = [~a]~%Endpoint = [~a]~%Parameters = [~a]~%Response = [~a]" ',method-name ,endpoint parameters (flexi-streams:octets-to-string body :external-format :utf-8)))))))))) + +(defmethod get-dns-records ((dns dns) recordtype ref name ipv4addr ipv6addr canonical ptrdname) + (declare (special recordtype ref name ipv4addr ipv6addr canonical ptrdname)) + (let ((dns-record (make-dns-record dns recordtype))) + (loop for param in (intersect-dns-record-function-args dns-record 'get-dns-records) do + (setf (slot-value dns-record (param-to-slot dns-record param)) (sanitize-dns-filter-param (symbol-value param)))) + (get-dns-records-impl dns dns-record))) + +(define-dns-impl (get-dns-records-impl :get) + (remove-if 'null (mapcar (lambda (rec) + (when (search-filter-satisfied-p dns-record rec) rec)) + (json-to-object (type-of dns-record) (cdar (json:decode-json-from-string (flexi-streams:octets-to-string body :external-format :utf-8))))))) + +(defmethod add-dns-record ((dns dns) (dns-record dns-record)) + (add-dns-record-impl dns dns-record)) + +(define-dns-impl (add-dns-record-impl :post) + (json:decode-json-from-string (flexi-streams:octets-to-string body :external-format :utf-8))) + +(defmethod modify-dns-record ((dns dns) (dns-record dns-record)) + (modify-dns-record-impl dns dns-record)) + +(define-dns-impl (modify-dns-record-impl :put) + (json:decode-json-from-string (flexi-streams:octets-to-string body :external-format :utf-8))) + +(defmethod modify-dns-record-ttl ((dns dns) (dns-record dns-record)) + (modify-dns-record-ttl-impl dns dns-record)) + +(define-dns-impl (modify-dns-record-ttl-impl :put) + (json:decode-json-from-string (flexi-streams:octets-to-string body :external-format :utf-8))) + +(defmethod delete-dns-record ((dns dns) (dns-record dns-record)) + (delete-dns-record-impl dns dns-record)) + +(define-dns-impl (delete-dns-record-impl :delete) + (json:decode-json-from-string (flexi-streams:octets-to-string body :external-format :utf-8))) diff --git a/lisp/entity/entity.lisp b/lisp/entity/entity.lisp new file mode 100644 index 0000000..cf342cf --- /dev/null +++ b/lisp/entity/entity.lisp @@ -0,0 +1,44 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:dns-admin) + +(defclass entity () + () + (:documentation "Superclass for all entity objects. An entity object +is one that represents a single tuple from a data source, like a SQL +table or DNS record.")) + +(defmacro with-entity-slots-to-list ((entity slot) &body body) + "Iterates over all the slots of `entity' and builds an alist based +on those slots. `slot' is the iterator." + `(remove-if 'null (mapcar (lambda (x) + (when (slot-is-field-p x) + ,@body)) + (map-slot-names ,entity)))) + +(defmethod attribute-value-list ((entity entity) &optional (keep-nulls nil)) + (with-entity-slots-to-list (entity slot) + (when (or keep-nulls + (and (not keep-nulls) + (not (null-or-empty-p (slot-value entity slot))))) + `(,slot . ,(slot-value entity slot))))) + +(defmethod get-slots-regex ((entity entity) regex) + (sort (remove-if-not (lambda (x) (match-it regex (symbol-name x))) + (map-slot-names entity)) + (lambda (x y) (string< (symbol-name x) (symbol-name y))))) + +(defmethod intersect-slots ((entity entity) slots) + (let ((intersect-slots ())) + (loop for class-slot in (map-slot-names entity) do + (let ((class-slot-string (parse-symbol class-slot))) + (loop for arg-slot in slots do + (let ((arg-slot-string (parse-symbol arg-slot))) + (when (string-equal class-slot-string arg-slot-string) + (push class-slot intersect-slots)))))) + (nreverse intersect-slots))) + +(defun slot-is-field-p (slot) + (let ((name (symbol-name slot))) + (and (equal name (ppcre:regex-replace "^\\*" name ""))))) diff --git a/lisp/entity/generics.lisp b/lisp/entity/generics.lisp new file mode 100644 index 0000000..d4929d3 --- /dev/null +++ b/lisp/entity/generics.lisp @@ -0,0 +1,51 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:dns-admin) + +(defgeneric attribute-value-list (entity &optional keep-nulls) + (:documentation "Builds an alist of attribute/value pairs.")) + +(defgeneric get-slots-regex (entity regex) + (:documentation "Gets an alphabetically sorted list of `entity' +slots whose names match `regex'.")) + +(defgeneric intersect-slots (entity slots) + (:documentation "Since the built-in `intersect' function does not +take package name prefixes into account, and since `map-slot-names' +returns slot names prefixed with the package name, this method was +written to intersect lists ignoring package prefixes.")) + +(defgeneric slot-to-param (dns-record-infoblox slot) + (:documentation "")) + +(defgeneric param-to-slot (dns-record-infoblox param) + (:documentation "")) + +(defgeneric make-dns-record (dns recordtype) + (:documentation "")) + +(defgeneric intersect-dns-record-function-args (dns-record func-symbol) + (:documentation "")) + +(defgeneric intersect-dns-record-function-args (dns-record func-symbol) + (:documentation "")) + +(defgeneric search-filter-satisfied-p (dns-record rec) + (:documentation "")) + +(defgeneric get-dns-records (dns recordtype ref name ipv4addr ipv6addr canonical ptrdname) + + (:documentation "")) + +(defgeneric add-dns-record (dns dns-record) + (:documentation "")) + +(defgeneric modify-dns-record (dns dns-record) + (:documentation "")) + +(defgeneric modify-dns-record-ttl (dns dns-record) + (:documentation "")) + +(defgeneric delete-dns-record (dns dns-record) + (:documentation "")) |